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PREFACE 


This  manual  is  divided  into  two  segments: 


1,  CLAIM  source  listings 

The  system  executive,  CLAIM,  is  presented  first,  followed 
by  all  CLAIM  subprograms,  listed  in  alphabetical  order. 

2.  CLAIM  swap  control  programs 

These  programs  contain  the  majority  of  the  system  dependent 
code  required  to  swap  control  between  various  program  segments. 
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THE  CLAIM  RECLAMATION  PLANNING  SYSTEM  WAS  DEVELOPED  BY 
DR*  M*  DOUGLAS  SCOTT  OF  MONTANA  STATE  UNIVERSITY  FOR  THE 
SERVICE?  AND  PROGRAMMED  BY  ORVILLE  D<  GREEN 


USDA  FOREST 


AND  STEVEN  A«  EASTMAN* 
THE  FEASIBILITY  ANALYSIS 
EXPANDED  THE  SYSTEM  TO 


ITS 


EASTMAN  LAID  THE  GROUNDWORK  FOR 
AND  SPOILS  GRADING?  WHILE  GREEN 
PRESENT  CAPABILITIES* 


THE  CLAIM  SYSTEM  PROVIDES  THE  RECLAMATION  ENGINEER  WITH  AN 


ENVIRONMENTAL 
ANALYSIS?  AND 


FEASIBILITY  RANKING?  A TECHNIQUES  AND  ECONOMICS 
AN  OPTIMUM  USE  COMPARISON  FOR  THE  FIVE  POST 
MINING  LAND  USES  J CROPLAND?  NATIVE  VEGETATION?  WILDLIFE? 
WATER  RECREATION?  AND  HIGH  USE*  ENVIRONMEN I AL  FEASIBILITY 
ARE  ALSO  AVAILABLE  FOR  AN  ARBRITRARY  -OTHER"  LAND  USE* 


ENVIRONMENTAL  FEASIBILITY  RANKINGS  ARE  DETERMINED  BY  AVERAGING 
•EXPECTATION  Oi"  SUCCESS"  VALUES  ASSOCIAIED  WITH  EACH  CATEGORY 
RESPONSE*  THE  EXPECTATION  VALUES  ARE  INTEGERS  IN  THE  RANGE  0-4? 
WHERE  0 MEANS  IMPOSSIBLE?  AND  4 MEANS  MANDATORY*  CATEGORY 
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C RESPONSES  ARE  GROUPED  INTO  TEN  SETS  : 
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!♦)  GENERAL  MINE  DESCRIPTION 
2.)  CLIMATOLOGY 
3*)  TOPSOIL 
4.)  SUBSOIL 
5*)  OVERBURDEN 
6*y  SURFACE  WATER  HYDROLOGY 
7.)  GROUND  WATER  HYDROLOGY 
B«)  VEGETATION 
9.)  ANIMALS 
10.)  SOCIO-ECONOMICS 

EACH  OF  THE  ABOVE  CATEGORIES  C0N7AIN  A NUMBER  OF  HEADINGS? 
WHICH?  IN  TURN?  CONTAIN  SEVERAL  SUBHEADINGS  : 

I.)  CATEGORY 
A.)  HEADING 

1.)  SUBHEADING?  ETC. 

EACH  SUBHEADING  IS  ASSIGNED  AN  EXPECTATION  VALUE  FOR  EACH 
OF  THE  FIVE  LAND  USES?  AND  THE  ‘OTHER*  CATEGORY. 

THE  TECHNIQUES  AND  ECONOMICS  ANALYSIS  SEARCHES  THE 
ENVIRONMENTAL  RESPONSE  SET  FOR  SPECIFIC  COMBINATIONS 
OF  CATEGORY  RESPONSES  THAT  REQUIRE  AN  ADDITIONAL  ENTRY 
TO  THE  -DEFAULT*  LIST?  OR  DELETION  OF  AN  ENTRY  FROM 
THE  DEFAULT  LIST.  ALSO  INCLUDED  IN  THE  TECHNIQUES  AND 
ECONOMICS  ANALYSIS  IS  A COST  FOR  GRADING  SPOILS*  SPOILS 
GRADING  IS  SIMULATED  FOR  BOTH  THE  DRAGLINE  AND  TRUCK  AND 
SHOVEL  TYPE  SURFACE  MINES. 

THE  OPTIMUM  USE  FACTORS  COMBINES  BOTH  THE  FEASIBILITY  RANKINGS 
AND  THE  COSTS  DETERMINED  BY  THE  TECHNIQUES  AND  ECONOMICS 
ANALYSIS  to  DETERMINE  THE  "BEST-  POST  MINING  LAND  USE  OPTION. 

THE  -OTHER-  CATEGORY  IS  NOT  CONSIDERED  IN  EITHER  THE  TECHNIQUES 
AND  ECONOMICS  ANALYSIS?  OR  THE  OPTIMUM  USE  DETERMINATION. 

THIS  OPTION  IS  TOTALLY  DEFINED  BY  THE  USER. 


C 

C PROGRAM  CLAIM  IS  THE  MAIN  EXECUTIVE  FOR  THE  CLAIM  SYSTEM. 

C SUBPROGRAMS  ARE  SCHEDULED  ACCORDING  TO  USER  SELECTION  TO 
C OPTION  MENUS.  THE  OPTION  MENUS  FORM  A TREE  THAT  THE  USER 
C MUST  CLIMB  DOWN?  AND  THEN  BACK  UP  AGAIN*  THE  OPTION  MENUS 
C PRESENTED  IN  THIS  PROGRAM  ARE  EASILY  READ  IN  THE  FORMAT 
C STATEMENTS  AT  THE  END  OF  THE  PROGRAM. 
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PROGRAM  CLAIM  SCHEDULES  THE  FOLLOWING  SUBROUTINES  I 
“GETID*  TO  GET  THE  INITIAL  DATA 

-IBNEV-  TO  INPUT/STORE  NON-STANDARD  EXPECTATION  VALUES 

-GDE"  TO  HANDLE  GENERAL  DESCRIPTION  ENTRIES 

“EIAD**  TO  HANDLE  ENVIRONMENTAL  INPUT  (ABBREVIATED  DISPLAY) 

-EIFD-  10  HANDLE  ENVIRONMENTAL  INPUT/EDIT  (FULL  DISPLAY) 

‘SRCD“  TO  SrORE/RETRIEVE  CLAIM  DATA 

-DCDSl-  AND  ‘DCDS2“  10  DISPLAY  THE  CURRENT  DATA  SET 

*DCEV*  TO  DISPLAY  7HE  CURRENT  EXPECTATION  VALUES 

"TSGE“  TO  HANDLE  T1-5JCK  AND  SHOVEL  GRADING  -GRADE  SPOILS  ONLY  OPTION 
-FEASI-  TO  COMPUTE  FEASIBILITY  RANKINGS 

•'TECON-  TO  DETERMINE  THE  TECHNIQUES  AND  ECONOMICS  LISTING 
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C "OPUSE"  TO  CALCULATE  OPTIMUM  USE  FACTORS 
C 'TFCD*  TO  TEST  FOR  COMPLETE  DATA 
C •'TCONE“  TO  EDIT  TECON  COSTS 
C 

C CLAIM  ALSO  USES  THE  SYSTEM  ROUTINES  J 
C "EXEC*  FOR  DISK  TRACK  ALLOCATION  (SWAP  CONTROL) 

C •RMPAR'  TO  RETRIEVE  THE  LOGICAL  UNIT  OF  THE  TERMINAL 
C 

C THE  TCS  ROUTINES  t ERASE r HOME r INITT » NEWPG,  AND  lOWAT  ARE 
C ALSO  USEIU 
C 

C PRINCIPAL  LOCAL  VARIABLES  ARE  t 


C 

C 

C 

C 

C 

C 


-IPTR'  - MAIN  OPTION  POINTER 

‘IPTRl"  - SUB  OPTION  POINTER 

•IMINE*  - CURRENT  TYPE  OF  MINE 

"ISTAGE"  - CURRENT  STAGE  IN  MINING  SEQUENCE 

'CSTEST"  - CURRENT  COST  TO  EXCAVATE  SPOIL 


C 

C THIS  EXECUTIVE  WAS  WRITTEN  BY  ORVILLE  D 
C 

C CLAIM  RELEASE  1.0  - APRIL  If 

C 

C ======  = =====:====  = ==  = =====:======r:=======:=========:=====.===:===:==  = 
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C 
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PROGRAM  CLAIM 

TEKTRONIX  COMMON 
COMMON  ITEK  (45) 

LOGICAL  UNITS  AND  COMMON  LOCATION 


C 

COMMON  1ARRY(5) j IARY2(5) y LERy LUFy LUL 
C 


C POINTERS 

C 


COMMON  EXIT  y I ANM ( 3 ) y I CL I < 2 ) y I GEN ( 3 ) y 1 GRW ( 5 ) 
COMMON  lOPTN  y IOVR< 7 ) y IPNTR  y ISOC < 6 ) y ISUB < 8 ) 
COMMON  ISUR(6) y IT0P<9) y 1VE6<2) y LEXIT  yLUO 
COMMON  MODE  yNANM  yNCLI  yNGEN  yNGRW 

COMMON  NOVR  yNSECTS  yNSOC  yNSUB  y NSUR 

COMMON  NTOP  yNU  yNVEG 

C 

C GRADING  PARAMETERS 

C 


COMMON  AREA(5) yBENLEN(5?10) y BENWI ( 5 y 10 ) y COGO y 6CPA ( 5 ) 
COMMON  GRDVBS ( 5 ) y HWHT  < 5 y 1 0 ) y HWSL I ( 5 y 1 0 ) y NSPP ( 5 ) y PCEQ 1 9(4) 
COMMON  PERCNT  < 5 y 1 0 ) y REHCP Y < 5 ) y REHVOL ( 5 ) y SLOPE ( 5 y 1 0 ) ? WBP 
C 

C CATEGORY  TEXT 

C 


COMMON  ANIM(23y 13) y CLMA( 13y 13) yGDESdSy 13) y6WHY(22y 13) 
COMMON  OVBD( 11 y 13) y SBSL(13) y SCEC(33y 13) ySWHY(44y 13) 
COMMON  TPSL(49y 13) y V6TA( 15y 13) 
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0167 

0168 

016? 

0170 

0171 

0172 

0173 

0174 

0175 

0176 

0177 

0178 

0179 

0180 

0181 

0182 

0183 

0184 

0185 

0186 

0187 

0188 

0189 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

0197 

0198 

0199 

0200 

0201 

0202 

0203 

0204 

0205 

0206 

0207 

0208 

0209 

0210 

0211 

0212 

0213 

0214 

0215 

0216 

0217 

0218 

0219 

0220 

0221 

%/  A-  ^ aU 


C 

C EXPECTATION  OALUES 

C 

COMHON  ANIMAL ( 1 3 y 6 ) y CLI MAT ( 8 y 6 ) y GENDES ( 8 y 6 ) y GRWH YD  < 19  y 6 ) 
COMMON  0VRBDN(28y6) yS0CECN(29y6) ySUBS01(30y6) ySURHYD<23y6) 
COMMON  TOPSOI <33y6) y0EGETA(10y6) 

C 

C CATEGORY  RESPONSES 


C 


C 


C 

C 


C 


C 


C 


C 


C 

C 

C 


C 

c 

c 


COMMON  RANIMA(3) yRCLIMA<2) yRGENDE(3) yRGRWHY(5) 
COMMON  R00RBD(7y 10) y RSOCEC < 6 ) y RSUBSO ( 8 ) y RSURHY ( 6 ) 
COMMON  RTOPSO ( 9 ) y RVE6ET  < 2 ) 


FEASIy TECONyOPUSE  SUBSYSTEM  PARAMETERS 


COMMON  CAAHM?CABAHyCABFN(3) yCABFP(3) yCABHM 

COMMON  CABS ( 2 ) y CAC  y CACP  y CADF  y CADH 

COMMON  CADS  y CAEAF  y CAHSAF  y CAHSTS  y CAIP 

COMMON  CAR3FC  y CASE  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y F A06 ( 5 ) y PFSTSP  y PFAC  y RCLTEC ( 29  y 34 ) 

COMMON  TCARJ'5)  y THICK  ( 10  ) y THKTS  y TTL  ( 40 ) 


INTEGER  EXI T y CLMA  y GDES  y GWHY  y OUBD  y SBSL 
INI  EGER  BCEC  y SWH Y y TPSL  y OGTA  y ANI M 
INTEGER  CLIMAT y GENDES yGRWH YD yOORBDN 
INTEGER  SOCECNySUBSDI y SURHYDy TOPSOI 
INIEGER  MEGETAyANIMAL 

1 NTE6ER  RCL I MA  y R6ENDE  y RGRUHY  y ROVRBD  y RSOCEC 
INTEGER  RSUBSO  y RSURHY  y RTOPSO y RMEGET  y RANIMA 
INTEGER  RCLTEC y TTL 


INTEGER  COMMON  <1) 
EQUIVALENCE  (COMMON 
EQUIVALENCE 
EQUIVALENCE 
EQUIVALENCE 
EQUIVALENCE 
EQUIVALENCE 


(lARRY 

(IARY2 

(1ARY2 

(IARY2 

(IARY2 


(1) 
Cl)  y 

(1) y 

(2)  y 

(3)  y 

(4)  y 


y ITEK  (1)) 
LUT) 

ISTRK) 

ISECT) 

I CODE) 

LEN) 


LOGICAL  LER 


DATA  LP/6/ 


CLEAR  IHE  COMMON  BLOCK 

DO  10  I = ly  6176 
10  COMMON(I)  = 0 


GET  THE  LOGICAL  UNIT  OF  THE  TERMINAL 


CALL  RMPAR(IARRY) 
IF(LUTtEQ.O)  LUT  = 1 
IARRY<2)  = 0 


C ALLOCATE  TRACKS  FOR  THE  COMMON  BLOCK 
C 
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/ 


0223 

0224 

0225 

0226 

0227 

0228 

0229 

0230 

0231 

0232 

0233 

0234 

0235 

0236 

0237 

0238 

0239 

0240 

0241 

0242 

0243 

0244 

0245 

0246 

0247 

0248 

0249 

0250 

0251 

0252 

0253 

0254 

0255 

0256 

0257 

0258 

0259 

0260 


CALL  EXEC(15y27lBTRKy IDXSC» ISECT) 
ISECT  = 0 
C 

C DE•^ER^^I^^E  ERASE  CAPABILITY 
C 

LER  ” < FALSE 
WRITE ( Lin  y 1000) 

READ  (LUTylOOl)  IANS 
IF<IANS*EQ*2HYE)  LER  = *TRUE« 

C 

C INITIALIZE  THE  COMMON  BLOCK 
C 

IF<LER)  CALL  INITTCLUf) 

IF(LER)  CALL  NLWPG 
IF < LER)  CALL  I0WAT(90) 

WRITE(LUTy 1002) 

CALL  6ETID 

1F(EXIT*EQ.~1)  GOTO  850 
C 

C DISPLAY  OPTIONS 
C 

25  IF(LER)  CALL  NEWP6 

IF(LER)  CALL  I0WAT<90) 

WRITE<LUf y 1002) 

WRI TE< LOT y 1003) 

30  READCLUI  s:^)  IPTR 

IF<IP^RcEQ^O)  GOTO  900 
1F<IPTR^EQ*5)  GOTO  500 
IF(IPTR.GE*1*AND.IPTR*LE*6)  GOTO  35 
WRI TEC LOT y 1004) 

- GOTO  30 
C 

C CLEAR  SCREEN  AND  BRANCH  TO  IPTR  OPTION 
C 

35  IF (LER)  CALL  NEHPG 

IF (LER)  CALL  I0WAT(90) 

WRITECLUTy 1002) 

GOTO ( 100 y 200 y 300 y 400 y 501? 600)  IPTR 


0261  C 

0262  C DATA  INPUT  OPTION 

0263  C 


0264 

0265 

0266 

0267 

0268 

0269 

0270 

0271 

0272 

0273 

0274 

0275 

0276 

0277 

0278 


100  MODE  = 1 
EXIT  = 2 
LEXIT  = 1 
lOPTN  = 1 
WRITECLUfy 1005) 

105  READCLUTy^:)  IPTR! 

IF ( IPTRi ^ GE . 0 ♦ AND ♦ IPTR! ♦ LE ♦ 8 ) 

>60TD(25? IlOy 120y 130y i40y 150? 160y 170y 190) 
WRITECLUTy 1004) 

GOTO  105 
C 

C MANUAL  INPUT  OF  THE  GENERAL  MINE  DESCRIPTION 
C 

no  IPMTR  = 1 
CALL  GDE 


IPTRl-M 
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0279 

0280 

0281 

0282 

0283 

0284 

0285 

0286 

0287 

0288 

0289 

0290 

0291 

0292 

0293 

0294 

0295 

0296 

0297 

0298 

0299 

0300 

0301 

0302 

0303 

0304 

0305 

0306 

0307 

0308 

0309 

0310 

0311 

0312 

0313 

0314 

0315 

0316 

0317 

0318 

0319 

0320 

0321 

0322 

0323 

0324 

0325 

0326 

0327 

0328 

0329 

0330 

0331 

0332 

0333 

0334 


C 

C 

C 


GOTO  180 


KILE  INF'UT  or  GENERAL  DESCRIPTION 

120  IPNTR  = 1 
GOTO  175 
C 

C MANUAL  INPUT  OF  ENVIRONMENTAL  DATA 
C 

130  IPNTR  = 2 

WR1TE<LUT  » 1006) 

READ (LUT, 1001 ) IANS 
IF<IANS*EQ*2HFD)  GOTO  135 

133  CALL  EIAD 
GOTO  180 

135  CALL  EIFD 
GOTO  180 
C 

C FILE  INPUT  OF  ENVIRONMENT AL  DATA 
C 

140  IPNTR  = 2 
GOTO  175 
C 

C FILE  INPUT  OF  ENTIRE  CLAIM  DATA  SET 
C 

150  IPNTR  = 3 
GOTO  175 
C 

C MANUAL  INPUT  OF  NON-STANDARD  EXPECTATION  VALUES 
C 

160  IPNTR  = 1 
GOTO  172 
C 

C FILE  INPUT  OF  NON  - STANDARD  EXPECTATION  VALUES 
C 

170  IPNTR  = 3 

172  CALL  ISNEV 
GOTO  35 
C 

C CALL  DATA  STORAGE  EXECUTIVE  TO  RETRIEVE  FILE 
C 

175  CALL  SRCD 
C 

C TEST  FOR  COMPLETE  DATA 
C 

180  CALL  TFCD 
MODE  = 1 

IFdOPTN.EQ*  1 ) GOTO (1 10 j 130?  130)  IPNTR 
GOTO  35 
C 

C INPUT  TITLE  TO  APPEAR  ON  OUTPUT 
C 

190  WRITE(LUT y 1020) 

READ(LUT? 1021)  TTL 
GOTO  35 
C 
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0335 

0336 

0337 

0338 

0339 

0340 

0341 

0342 

0343 
0344 

0345 

0346 

0347 

0348 

0349 
0350 

0351 

0352 

0353 

0354 
03'=' 


03! 


6 


0357 

0358 

0359 

0360 
0361 

0362 

0363 

0364 

0365 

0366 

0367 

0368 

0369 
0370 

0371 

0372 

0373 

0374 

0375 

0376 

0377 

0378 

0379 

0380 

0381 

0382 

0383 

0384 

0385 

0386 

0387 

0388 

0389 

0390 


C DATA  EDIT  OPTION 
C 

200  WRITE (LOT >1007) 

205  READ(LUI>)K)  IPTRl 

IE  < IPTfa  ♦ GE  * 0 . AND ♦ IPTRl ♦ LE ♦ 5 ) 

>G0T0(25>210>220>230>240>250)  IPTRl+1 
WRITE(LUT> 1004) 

GOTO  205 
C 

C EDIT  CATEGORY  RESPONSES  TO  THE  GENERAL  DESCRIPTION 
C 

210  MODE  = 2 
CALL  GDE 
GOTO  35 
C 

C EDIT  RESPONSES  TO  ENVIRONMENTAL  DATA 
C 

220  MODE  = 2 
GOTO  245 
C 

C EDIT  EXPECTATION  OF  SUCCESS  VALUES  FOR  THE  GENERAL  DESCRIPTION 
C 

230  MODE  = 3 
CALL  GDE 
GOTO  35 
C 

C EDIT  EXPECTATION  OF  SUCCESS  VALUES  FOR  ENVIRONMENTAL  DATA 
C 

240  MODE  = 3 
C 

C SCHEDULE  FULL  DISPLAY  ENVIRONMENTAL  EXECUTIVE 
C 

245  CALL  EIFD 
GOTO  35 
C 

C EDIT  TECON  COSTS 
C 

250  CALL  TCONE 
GOTO  35 
C 

C DATA  REVIEW  OPTION 
C 

300  WR1TE(LUT> 1008) 

305  READ  (LUTj^fO  IPTRl 

IF ( IPTRl ♦ GE  4 0 ♦ AND  ^ IPTRl <LE<2) 

>G0T0<25>310>330)  IPTRITI 
WRITE(LUT>1004) 

GOTO  305 

310  LUL  = LUT 

WRITE(LUT> 1009) 

READ  (LUT >1001)  IANS 
IF(IANS4EQ42HLP)  LUL  = LP 
GOTO (320 >330)  IPTRl 
C 

C DISPLAY  CURRENT  DATA  SET 
C 
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I 


0391 

0392 

0393 

0394 

0395 

0396 

0397 

0398 

0399 

0400 

0401 

0402 

0403 

0404 

0405 

0406 

0407 

0408 

0409 

0410 

0411 

0412 

0413 

0414 

0415 

0416 

0417 

0418 

0419 

0420 

0421 

0422 

0423 

0424 

0425 

0426 

0427 

0428 

0429 

0430 

0431 

0432 

0433 

0434 

0435 

0436 

0437 

0438 

0439 

0440 

0441 

0442 

0443 

0444 

0445 

0446 


C 

C 

C 


C 

C 

C 


C 

C 

C 


C 

C 

C 


C 

C 

C 


C 

C 

C 


320  CALL  OCnSl 

IK(EXIT*LQ»“1)  GOTO  35 
CALL  DCDS2 
GOTO  35 


DISPLAY  CURRENT  EXPECTATION  VALUES 


330  CALL  DCEV 
GOTO  35 

IiATA  STORAGE  OPTION 

400  lOPTN  = 2 

WRITE<LUT, 1010) 

405  READ  <LUT?)l:)  IPTRl 

ir  < 1 PTRl ♦ 6E ♦ 0 ♦ AND ♦ I PTRl ♦ LE ♦ 4 ) 
>GOTO  < 25  f 4 1 0 r 420  y 430  r 440 ) 1 PTRl  + 1 
WRITE < LU  r » 1004) 

GOTO  405 

STORE  GENERAL  DESCRIPTION 

410  IPNTR  = 1 
GOTO  435 

STORE  ENVIRONHENTAL  DATA  RESPONSES 

420  IPNTR  = 2 
GOTO  435 

STORE  THE  ENTIRE  CLAIH  DATA  SET 

430  IPNTR  = 3 

435  CALL  SRCD 
GOTO  35 


STORE  THE  CURRENT  CATEGORY  EXPECTATION  VALUES 


440  IPNTR  =••  2 


CALL  ISNEV 
GOTO  35 


C 

C DATA  ANALYSIS  OPTION 
C 

500  IPNTR  = 3 
CALL  TFCD 
MODE^l 

IF(I0PTN*EQ*1)  G0T0(110!.130y  130)  IPNTR 
IFCLER)  CALL  ERASE 
IF(LER)  CALL  HO.HE 

501  WRITE(LUTy 1011 ) 

505  READ  <LUTy^)  IPTRl 

IF ( IPTRl vEQ.O)  GOTO  25 
IF(IPTRl.GE*l*Ar-4D.  IPTRl  ♦LE^3)  GOTO  510 
URITE(LUTy 1004) 

GOTO  505 
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I 


I 


’ 0447 

516 

LUL  = LUT 

1 0443 

WRIT E<LUTr 1009) 

' 0449 

! 

READ  (LUT? 1001)  IANS 

0450 

IF(1ANS.EQ.2HLP)  LUL 

1 0451 

G0T0(520»530?540)  IPTRl 

i 0452 

C 

1 0453 

c 

FEA 

SIBILITY  ANALYSIS 

j 0454 

c 

i 0455 

520 

IPNTR  1 

0456 

CALL  FEASI 

1 0457 

GOTO  35 

j 045B 

c 

‘ ■ 

1 0459 

c 

TECON  ANALYSIS 

0460 

c 

0461 

530 

IPNTR  = 1 

0462 

CALL  TECON 

1 0463 

GOTO  ,35 

J 0464 

c 

0465 

c 

OPUSE  ANALYSIS 

0466 

c 

0467 

540 

IPNTR  =3 

0468 

CALL  FEASI 

; 0469 

CALL  TECON 

0470 

CALL  OPUSE 

? 0471 

GOTO  35 

i 0472 

c 

1 0473 

c 

GRADE  SPOILS  WITHOUT  LAND  US 

-1  0474 

c 

1 0475 

600 

M0DE=4 

1 0476 

LU0=1 

0477 

IHINE=RGENDE(1) 

j 0478 

ICUT=RGENDE(2) 

i 0479 

CSTEST=CSTES 

1 0480 

WRITE(LUfy 1012) 

j 0481 

605 

REALKLUTj  IPTRl 

i 0482 

IF< IPTRl ♦EQ*0)  GOTO  25 

1 0483 

IF<IPTf::l  .GT<0<  AND.  IPTRl 

1 0484 

WRITECLUT? 1004) 

‘ 0485 

GOTO  605 

• 0486 

610 

IF<IPTR1.GT.3)  GOTO  615 

j 0487 

R6ENDE(1)=:=1 

I 0488 

RGENDE(2)==IPTR1 

0489 

CALL  6DE 

0490 

GOTO  625 

* 0491 

615 

R6ENDE(i)=2 

! 0492 

R6ENDE(2)=IPTRl-3 

i 0493 

WRITE (LUT? 1022) 

^ 0494 

READ  (LUT?  5^0  C060 

‘ 0495 

IF(C0G0.EQ.-1 . ) GOTO  625 

0496 

CALL  TS6E 

0497 

GOTO  625 

0498 

c 

0499 

c 

RESi 

ET  TYPE  OF  MINE  AND  STAGE 

0500 

c 

OALUESj  and  SET  ALL  GRADING 

0501 

c 

! 0502 

625 

R6ENDE(1)==IMINE 

= LP 


GOTO  610 


IN  MINING  SEQUENCE 
ARAMETERS  TO  ZERO« 


TO  PRE-OPTION 
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0503  RGENI.IE  ( 2 ) = I CUT 

0504  CSTES=CSTEST 

0505  DO  630  128^794 

0506  630  C0MM0N<K)=0 

0507  GOTO  35 

0508  C 

0509  C COMMON  INITIALIZATION  FAILURE 

0510  C 

0511  850  WRirE(LUT>1013) 

0512  C 

0513  C RELEASE  TRACKS  AND  QUIT 

0514  C 

0515  900  CALL  EXEC( 16 ?2» ISTRKy IDISCj ISECT) 

0516  C 

0517  C FORMAT  STATEMENTS 

0518  C 

0519  1000  FORMAT dX" ARE  YOU  USING  A CRT  TERMINAL  WITH  ERASE'/ 

0520  > IX'CAPABILITY  ?<YES  OR  NO)  ~>  _') 

0521  C 

0522  1001  F0RMAT(A2) 

0523  C 

0524  1002  FORMAT  ( 15X ' )Jc  “ / 


0525 

15X')Jc 

tw 

0526 

> 

15X"^ 

CLAIM  tW 

0527 

*> 

15X'^ 

tw 

0528 

*5* 

15X")JJ 

COMPUTERIZED  RECLAMATION  tW 

0529 

15X">fc 

PLANNING  SYSTEM  / 

0530 

i5X*3fc 

tw 

0531 

0532 

C 

0533 

1003 

FORMAT < IX' 

“/ 

0534 

X 

IX “ OPTIONS  V 

0535 

IX*  — 

“// 

0536 

IX'O  - 

->  TERMINATE  CLAIM"// 

0537 

> 

IX'l  - 

~>  DATA  INPUT*// 

0538 

1X*2  - 

">  DATA  EDIT*// 

0539 

1X*3  - 

■•>  CURRENT  DATA  REOIEU"// 

0540 

1X*4  - 

->  DATA  STORAGE"// 

0541 

> 

1X*5  “ 

••>  DATA  ANALYSIS*// 

0542 

1X"6  - 

->  GRADE  SPOILS  WITHOUT  CURRENT*/ 

0543 

IX* 

LAND  USE  OPTION  RESTRICTIONS*/// 

0544 

0545 

c 

IX'ENTER  OPTION  SELECTION  ->  „*) 

0546 

0547 

1004 

C 

FORMAT < IX*  ?? 

ERROR*  RE-INPUT  ->  „ * ) 

0548 

1005 

FORMAT  < IX* 

1.  / 

0549 

S- 

IX*  DATA  INPUT  V 

0550 

1X"““- 

*// 

0551 

1X*0  - 

■•>  EXIT  FROM  DATA  INPUT  OPTION*// 

0552 

1X*1  - 

->  MANUAL  INPUT  OF  THE  GENERAL  MINE  DESCRIPTION* 

0553 

IX  *2  - 

->  FILE  INPUT  OF  THE  GENERAL  MINE  DESCRIPTION V/ 

0554 

*> 

1X*3  - 

“>  MANUAL  INPUT  OF  ENVIRONMENTAL  DATA*// 

0555 

> 

1X*4  - 

••>  FILE  INPUT  OF  ENMI RONMENi  AL  DATA"// 

0556 

> 

IX  *5 

FILE  INPUT  OF  BOTH  ENVIRONMENTAL  DATA  "/ 

0557 

> 

1X“ 

AND  GENERAL  MINE  DESCRIPTION*// 

0558 

IX'6  “ 

->  MANUAL  INPUT  OF  NON-STANDARD  EXPECTAT I ON ‘ 1 X 
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0559 

0560 

0561 

0562 

0563 

0564 

0565 

0566 

0567 

0568 

0569 

0570 

0571 

0572 

0573 

0574 

0575 

0576 

0577 

0578 

0579 

0580 

0581 

0582 

0583 

0584 

0585 

0586 

0587 

0588 

0589 

0590 

0591 


0611 

06.1.2 

0613 

0614 


y 


VALUES'// 

IX '7  FILE  INPUT  OF  NON~STANi:iAF<D  EXPECTATION " IX 
VALUES'// 

iX'8  INPUT  TITLE  TO  APPEAR  ON  ALL  OUTPUT'/// 
IX'ENTER  YOUR  SELECTION  ->  _') 


1006  FORMATdX'ABBREVIATED  OR  FULL  DISPLAY  ?(AD  OR  FD) 


' ) 


1007  F 


ORMATCIX' ■/ 

IX'  DATA  EDIT  '/ 
1X« ‘// 


y 


EXIT  FROM  DATA  EBIT  OPTION'// 

EDIT  THE  GENERAL  NINE  DESCRIPTION ' // 

EDIT  RESPONSES  TO  ENVI RONHENTAL  DATA'// 
EBIT  EXPECTATION  OF  SUCCESS  VALUES  FOR'/ 
THE  GENERAL  NINE  DESCRIPTION'// 

EDIT  EXPECTATION  OF  SUCCESS  VALUES  FOR'/ 
ENVIRONMENTAL  DATA'// 

EDIT  TECON  COSTS'/// 


IX'O  - 
IX'l  - 
lX-2  - 
iX'3  - 
IX" 

1X“4  - 
iX“ 

iX'5  ~ 

IX'ENTER  YOUR  SELECTION 


1008  FORMAT < IX 


y 

> 

’> 


./ 

IX*  CURRENT  DATA  REVIEW  "/ 

IX- V/ 

IX'O  ->  EXIT  FROM  DATA  REVIEW  OPTION'// 

IX'i  ~>  DISPLAY  CURRENT  CLAIM  DATA  SET'// 

iX"2  DISPLAY  CURRENT  EXPECTATION  OF  SUCCESS' IX 


VALUES'/// 


C 


> IX'ENTER  YOUR  SELECTION  y ') 

1009  FORMATCIX'DISPLAY  ON  TERMINAL  OR  LINE  PRINTER  ?(TT  OR  LP) 


C 


1010  FORMAT (IX' 


0592 

s, 

y 

IX' 

0593 

y 

IX'- 

0594 

y 

IX'O 

0595 

IX'l 

0596 

iX'2 

0597 

s. 

X 

IX  “3 

0598 

IX’ 

0599 

IX'4 

0600 

X* 

‘VALUES'/// 

0601 

[> 

IX'E 

0602 

c 

0603 

1011 

FORMAT ( IX ' — 

0604 

> 

IX' 

0605 

X 

1X'~ 

0606 

IX'O 

0607 

Jr 

IX'l 

0608 

y 

iX'2 

0609 

> 

IX'3 

0610 

IX'E 

•/ 

"/ 

“'// 


> STORE  THE  CURRENT  GENERAL  DESCRIPTION'// 

> STORE  THE  ENVIRONMENTAL  DATA'// 

> STORE  BOTH  THE  GENERAL  MINE  DESCRIPTION  AND'/ 
THE  ENVIRONMENTAL  DATA'// 

> STORE  THE  CURRENT  EXPECTATION  OF  SUCCESS 'IX 


) 


V 

TA  ANALYSIS  */ 

-// 

.>  EXIT  FROM  DATA  ANALYSIS  OPTIOM'//y 
:>  ENVIRONMENTAL  FEASIBILITY  RANKINGS"//? 
.>  TECHNIQUES  AND  ECONOMICS  ANALYSIS'//? 

:>  OPTIMUM  USE  FACTORS'/// 

IX'ENTER  YOUR  SELECTION  ->  _') 


C 


1012  FORMAT  (IX' 

•>  IX'  GRADE  SPOILS  WITHOUT'/ 

> IX'  LAND  USE  OPTION  RESTRICTIONS"/ 


/ 
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0615 

0616 

0617 

0618 

0619 

0620 
0621 
0622 

0623 

0624 

0625 

0626 

0627 

0628 

0629 

0630 

0631 

0632 

0633 

0634 


> IX" •// 

> 1X"0  ”>  EXIT  EROH  GRADE  SPOILS  OPTION"// 

> IX" 1 ->  DRAGLINE  - OPENING  CUT  OPTION"// 

> 1X"2  “>  DRAGLINE  - MINE  RUN  OPTION"// 

> IX "3  “>  DRAGLINE  - FINAL  CUT  OPTION"// 

> 1X"4  ->  TRUCK  AND  SHOUEL  - OPENING  CUT  OPTION"// 

> IX "5  ->  TRUCK  AND  SHOUEL  - MINE  RUN  OPTION"// 

> ' IX "6  ->  TRUCK  AND  SHOUEL  - FINAL  CUT  OPTION"/// 

IX'ENTER  YOUR  SELECTION  ~>  _") 

C 

1013  FORMAT(lX"SORRYy 1 CAN'T  SEEM  TO  GET  ORGANIZED  TODAY."/ 

> IX "TRY  ME  SOME  OTHER  TIME.") 

C 

1020  FORMAT < IX "INPUT  TITLE  ->  ^‘) 

C 

1021  FORMAT (40A2) 

C 

1022  FORMAT("  ENTER  THE  COST  OF  GRADING  SPOILS(CENTS  / CU  YD) 
END 

ENDT> 
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SALTRM  T=00004  IS  ON  CR00015  USING  00002  BLKS  K*=0000 

! 


0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 
0009 


FTN4 

C LABEL  COHNON  ALTRN  (ALTERNATIVE  HEADINGS) 

BLOCK  DATA  ALTRN 
COMMON  /ALTRN/  ALIN 
INTEGER  ALTN(6r4) 

DATA  ALTN/2HCR  ? 2HNA  r 2HU I » 2HWA  y 2HHI r 2H0 f j 2H0P , 2HT ♦ , 2HLD  ? 2HT ♦ » 2H6H , 
t 2HHE»2HLAj2HVE?2HLIy2HREj2H  Uj2HR  y 2HND , 2HG ♦ y 2HFE j 2HC . f 2HSE j 2H  / 
END 

END$ 


\ 


T=00004  IS  ON  CROOOiS  USING  00039  BLKS  R=0272 

0001  FTN4 

0002  SUBROUTINE  ANIhA  ' 

0003  C FULL  DISPLAY— CATEGORY  9 / ANIHALS 

0004  C 

0005  C LEVEL  2 

0006  C 

0007  C ANINA  IS  ACCESSED  BY  EIFD  TO  SCHEDULE  INPUIS  AND  EDITS  TO 

0008  C CATEGORY  VALUES?  AND  EDITS  TO  EXPECTATION  OF  SUCCESS  VALUES 

0009  C FOR  CATEGORY  9 - ANIMALS?  USING  FULL  DISPLAY* 


0010 

c 

0011 

c 

THE 

CALLING 

SEQUENCE  IS  1 CALL  ANIMA 

0012 

c 

0013 

c 

ANIMA  USES 

THE  TCS  ROUTINES  I ERASE  AND  HOME 

0014 

c 

0015 

c 

THE 

LOCAL  VARIABLES  ARE  : 

0016 

c 

IANS 

->  ANSWER  CELL 

0017 

c 

II 

“>  “1“  INDEX  1.  (I?J)  3 TO  CL  I MAT  ARRAY 

0018 

c 

I OLD 

->  PRE-EDIT  CATEGORY  RESPONSE  VALUE 

0019 

c 

LUORN 

~>  LAND  USE  OPTION  REFERENCE  NUMBER  : 

0020 

c 

1 ->  CROPLAND 

0021 

c 

2 ->  NATIVE  VEGETATION 

0022 

c 

3 ->  WILDLIFE 

0023 

c 

4 ->  WATER  RECREATION 

0024 

c 

5 ->  HIGH  USE 

0025 

c 

6 ->  OTHER 

0026 

c 

NN 

->  HEADING  NUMBER 

0027 

c 

002B 

c 

ANIMA  IS  SWAPPED  LN  BY  PROGRAM  ANIMX 

0029 

c 

0030 

c 

THIS 

: ROUTINE  WAS  WRITTEN  BY  GREEN 

0031 

c 

0032 

c 

CLAIM  RELEASE  1*0  - APRIL  1?  1980 

0033 

c 

0034 

c 

0035 

c 

TEKTRONIX  COMMON 

0036 

c 

0037 

COMMON 

ITEK  (45) 

0038 

c 

0039 

c 

LOGICAL 

UNITS  AND  COMMON  LOCATION 

0040 

c 

0041 

COMMON 

IARRY(5) ?IARY2(5) ?LER?LUF?LUL 

0042 

c 

0043 

c 

POINTER 

S 

0044 

c 

0045 

COMMON 

EXIT  ? 1ANM(3) ? ICLI (2) ? IGEN ( 3 ) ? IGRW< 5 ) 

0046 

COMMON 

lOPTN  ? ICVR ( 7 ) ? IPNTR  ? XBOC ( 6 ) ? I SUB ( 8 ) 

0047 

COMMON 

ISUR<6) ?IT0P(9) ? 1VEG(2) fLEXIT  ?LU0 

0048 

COMMON 

MODE  fNANM  fNCLI  ?NGEN  ?N6RW 

0049 

COMMON 

NOVR  ?MSECTS  ?MSOC  ?NSUB  ?NSUR 

0050 

COMMON 

NTOP  ?NU  ?NVE6 

0051  c 

0052  C GRADING  PARAMETERS 

0053  C 

0054 


COMMON  AREA  ( 5 ) ? BENLEN  < 5 ? 10 ) ? BENU! I ( 5 ? 1 0 ) ? COGO  ? GCPA  ( 5 ) 


005S 
, 0056 

0057 

0058 

0059 
! 0060 

006i 
■ 0062 

0063 

0064 

0065 

0066 
0067 

5 0068 

0069 

0070 
; 0071 
I 0072 
f 0073 

0074 

0075 

0076 

0077 

0078 

0079 
0030 
0081 
0082 

0083 

0084 

0085 

0086 
0087 

I 0088 

^ 0089 

I 0090 
1 0091 

; 0092 

0093 

0094 

0095 

0096 

0097 

0098 
! 0099 
; 0100 

0101 

0102 

0103 

0104 

0105 

0106 
0107 
0.108 

0109 

0110 


C 

C 

r> 

Ur 


C 

c 

c 


c 

c 

c 


c 

c 

c 


c 


c 


c 

c 

c 

c 

c 


COHMON  GRD0BS(5)  ?HWHT(5f  10)  jHIJSLI  <5>  10)  tNSPP(5)  yPCf£Q19(4) 
CO«HON  PERCNT  < 5 > 1 0 ) » REHCP Y ( 5 ) t REHMOL ( 5 ) j SLOPE ( 5 y 1 0 ) y WBP 

CATEGORY  TEXT 

COMMON  ANIM<23r  13)  rCLMA(13y  13)  f GDESdSy  13)  yGWHY(22y  13) 
COMMON  0UBD<llyl3)ySBSL(13)y  SCEC < 33 y 1 3 ) r SWHY < 44 y 1 3 ) 
COMMON  TPSL(49y  13)  yOGTAdSy  13) 

EXPECTATION  OALUES 

COMMON  ANIMAL(13y6) yCLIMAT<8y6) yGENBES<8y6) y6RWHYB<19y 
COMMON  00RBUN(28y6) yS0CECN<29y6) ySUBS0I(30y6) ySURHYD(2 
COMMON  T0PS0K33y6)  y0E6ETAd0y6) 

CATEGORY  RESPONSES 

COMMON  RANIMA(3) yRCLIMA<2) yR6ENDE(3) yRGRWHY(5) 

COMMON  ROVRBD ( 7 y 1 0 ) y RSOCEC  < 6 ) y RSUBSO ( 8 ) y RSURH Y ( 6 ) 

COMMON  RT0PS0(9) yRMEGET<2) 


FEASIyTECONyOPUSE  SUBSYSTEM  PARAMETERS 

COMMON  CA AHM  y CABAH  y CABF  N ( 3 ) y CABFP ( 3 ) y CAHBM 

COMMON  CABS ( 2 ) y CAC  y CACP  y CADF  y CABH 

COMMON  CADS  y CAEAF  y CAHSAF  ? CAHSTS  y CAIP 

COMMON  CAR3FC  y CASF  y CASNC  y CSTES  ? CSTRM 

COMMON  CSTRP  y F AVG ( 5 ) y PFSTSP  y PF AC  y RCL7  EC  < 29  y 34 ) 

COMMON  TCAR(5)  yTHICKdO)  yTHKTSy  TTL<40) 


INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 


EXI T y CLMA  y GDES  y GWHY  y OMBD  y SBSL 
SCEC  y SWH Y y TPSL  y MGTA  y ANIM 
CLl MAT  y 6ENDES  y GRUH YD  y OVRBDN 
BOCECN y SUBSOI y SURHYD y TOPSOI 
VEGETA y ANIMAL 

RCL I MA  y R6ENDE  y R6RUHY  y ROVRBD  y RSOCEC 
RSUBSO yRSURHYyRTOPSOyRMEGETy RANI  MA 
RCLTECyTTL 


INTEGER  COMMON  d) 

EQUIVALENCE  (COMMON  d)y  ITEK  d)) 


EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 


(lARRY 

(IARY2 

(IARY2 

<IARY2 

(IARY2 


d)  y 
d ) y 

(2)  y 

(3)  y 

(4)  y 


LUT  ) 
ISTRK) 
ISECT) 
I CODE) 
LEN) 


LOGICAL  LER 


DISPLAY  MODE 

1 IF <♦ NOT ♦LER)  GOTO  5 
CALL  E’RASE 
CALL  HOME 

5 GDT0d0y20y  30)  MODE 


15 


C*4  CN 


0111 

0112 

0113 

OllA 

0115 

0116 

0117 

0118 

0119 

0120 
0121 
0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 
0161 
0162 

0163 

0164 

0165 

0166 


10  WRITE(LUT>1010) 

GOTO  40 

20  WRI TE < LOT y 2010) 

GOTO  40 

30  WRITE (LOT y 3010) 

40  IF(  M0IiE*6T*l)  GOTO  50 
60T0<100y200y300)  LEXIT 

C USER  INPUT  ->  EDIT  HEADING 

50  WRI TE(LUTy 2020) 

51  READ  (LUTy2030)  IANS 

IF(IANS*ECU2HA  ) GOTO  100 
1F(IANS.EQ.2HD  ) GOTO  200 
IF(IANS*EQ*2HC  ) GOTO  300 
IF(IANS»E0*2HN0)  RETURN 
WRITECLUfy 1200) 

GOTO  51 

C EDIT  EXPECTATIONS 

C USER  INPUT  ->  SUBHEADING  NUMBER 

52  WRITE<LUTy3020) 

57  READ  (LUfy)t:)  II 
GOTO  85 

C USER  INPUT  ->  LAND  USE  OPTION  REFERENCE  NUMBER 

54  WRITE(LUTy3030) 

55  READ  <LUTy>^)  LUO 

IF(LU0*GE*1*AND*LU0.LE*6)  GOTO  56 
WRITE(LUTy 1200) 

GOTO  55 

56  II=-II  + L 

C USER  INPUT  ->  EXPECTATION  OALUE 

58  WRITE(LUf y3040) 

59  READ  (LU  fyJfO  ANIMAL  ( 1 1 y LUO ) 

IF ( AN I MAL ( 1 1 y LUO ) ♦ 6E ♦ 0 ♦ AND ♦ ANIMAL ( 1 1 y LUO ) ♦ LE ♦ 4 ) 

+ GOTO  600 
WRlTE<LUTy3050) 

GOTO  59 

C EDIT  RESPONSES 

60  lOLD  =■•  RANIHA(NN) 

65  WRITE(LUTy2040)  lOLD 
GOTO  83 

C INPUT  RESPONSES 

C USER  INPUT  “>  RANIMA<NN) 

70  WRITE<LUTy2000) 

83  READ  (LUTy^)  RANIMA(NN) 

IF(RANIMA(NN) ♦ECUO)  G0T0(900yB7)  MODE 
II=RANIMA(NN) 

85  IFd  l .GE  M tAND^II  a..E*  lANM(NN)  ) GOTO < 700 y 600 y 54  ) MODE 

87  WRITE(LUTy 1200) 

GOTO ( 83 y S3 y 57)  MODE 

C DISPLAY  HEADING  A ->  WILDLIFE  TYPES 

100  NN=1 
J==l 
L==0 

IF(MODE.NEM.ANDcLER)  CALL  ERASE 
1F(MGDE.NEM  . AND.LER)  CALL  HOME 
105  WRITE<LUTy  1000)  ( ANI M ( 1 y I ) y I ==i  y 1 3 ) 

WRITE<LUTy 1020) 
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0167 

0168 

0169 

0170 

0171 

0172 

0173 

0174 

0175 

0176 

0177 

0178 

0179 

0180 
0181 
0182 

0183 

0184 

0185 

0186 

0187 

0188 

0189 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

0197 

0198 

0199 

0200 
0201 
0202 

0203 

0204 

0205 

0206 

0207 

0208 

0209 

0210 
0211 
0212 

0213 

0214 

0215 

0216 

0217 

0218 

0219 

0220 
0221 
0222 


C 


WRITECLUTy 1050) 
WRITE<LUr>1100) 

WRITE(LUf »1050) 

WRITE(LUI 51100) 
WRITE(LUT5l050) 
WRITECLUIMIOO) 
WRITE(LUT5l050) 

WRITE(LUT5 1100) 
WRITE(LUT5l050) 
WRITE(LUT5ll00) 
WRITE(LUT5l050) 

WRI TE<LUT5 1100) 

110  6010(70560552)  MODE 

DISPLAY  HEADING 

200  NN  = 2 

J=IANM(1)+1 
L=J“1 

IF<  *NOT*LER) 

CALL  ERASE 
CALL  HOME 
WRITE(LUT5lOOO) 

205  WRirE(LUI 51020) 

WRITE<LUT5 1050) 
WRITE(LUT5l050) 

WR1TE(LUT5 1100) 
WRITE(LUT5l050) 

WRITE (LOT  5 1100) 

WRITE(LUT5 1050) 

WRITE (LUT 5 1100) 

WRITECLUTy 1050) 
WRITECLUTyliOO) 

KK=5 

WRITE (LUT  5 1051) 
WRITE(LUT5ll00) 

GOTO (70 5 60 5 52) 

DISPLAY  HEADING 

300  NN=3 

J=IANM(l)+iANM(2)Tl 
L=J-1 

IF( .NOT.LER) 

CALL  ERASE 
CALL  HOME 
WRITE (LUT 5 1000) 

WRITE(LU  fy 1020) 

WRITE (LUT 5 1050) 

DO  310  K=18yl9 
WRITE(LUTyllOO) 

J=J-fl 

GOTO ( 70 5 60 y 52)  MODE 
USER  INPUT 
WRITE (LUT  5 3060) 

READ  (LUT 5 2030)  IANS 

IF(IANS.NE*2HYE) 

GOTO  1 

INPUT  MODE  ->  DIRECT 
700  IF(NNtEQ.NANM)  RETURN 


( (ANIM(Ky I ) 5 I=ly 13) yK=2y4) 
(ANIM(5yl)5l=l5l3) 5 (ANIMAL(l5l)5l=ly6) 
(ANIM(65l)yI=l5l3) 

(ANIM(75l)5l  = lyl3)5 (ANIMAL (25 1 ) y 1 = 1 56) 
(ANIH(85l)5l=lyl3) 

(ANIM(95l)5l=l5l3)y (ANIMAL(3y I ) 5 1=1 56) 
((ANIM(Kyl) 5l=lyl3) yK=10y 12) 

(ANIM(13y I ) 5 1=1 5 13) 5 (ANIMAL(4y I ) 5 1=1 56) 
(ANIM(145l)yI=l5l3) 

(ANIMdSyl)  5l  = lyl3)  5 (ANIMAL(5yI)  y I = ly6) 
(ANIM(225i)5l=lyl3) 

(ANIM(23y I) 5 I = ly 13) 5 (ANIMAL (65 1 ) 5 1 = 1 56) 


B ~>  CURRENT  SECONDARY  TYPES 


GOTO  205 


(ANIM(lyl)5l=l5l3) 

((ANIM(KyI)yI=l5l3) 5K=20y21) 
(ANIM(45l)yI=lyl3) 

(ANIH(55l)5l=lyl3) 5 ( ANIMAL ( 7 y I ) y 1=1 5 6 ) 
(ANIM(6yI) 5l=iyl3) 

(ANIM(7yI) 5l  = l5l3)y ( ANIMAL ( 8 5 1 ) 5 I = 1 5 6 ) 
(ANIM(85l)yI=lyl3) 

(ANIM(9yI) yl  = ly 13) 5 ( ANIMAL ( 9 5 1 ) 5 1 = 1 y 6 ) 

< (ANIH(Ky I) 5 1=1 5 13) 5K=10y 12) 

(ANIM(13yI) y 1=1 5 13) 5 ( ANIMAL ( 10 y I ) 5 1=1 5 6) 


KKy (ANIM(22y I) 5l=3yl3) 

(ANIM(23y l)5l=lyl3)5(ANIMAL(ll5l>5l^ 
MODE 

C ~>  LIVESTOCK  GRAZING 


GOTO  305 


(ANIM(lyI)yI=lyl3) 


ly6) 


305 


310 


600 


((ANIM(KyI)5l=l5l3)5K: 


16yl7) 


(ANIM(Ky I ) 5 1=1 5 13) y (ANIMAL (Jy I ) y 1=1 y 6) 


MORE  EDITS  ? 


RETURN 


TO  PROPER  HEADING 
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SET  EXIT  TO  ZERO  AND  RETURN 


0223 

0224 

0225 

0226 

0227 

0228 

0229 

0230 

0231 

0232 

0233 

0234 

0235 

0236 

0237 

0238 

0239 

0240 

0241 

0242 

0243 

0244 

0245 

0246 

0247 

0248 

0249 

0250 

0251 

0252 

0253 

0254 

0255 

0256 

0257 
025.8 

0259 

0260 
0261 
0262 

0263 

0264 

0265 

0266 

0267 

0268 

0269 

0270 

0271 

0272 

0273 

0274 

0275 

0276 

0277 

0278 


GOTO  < 200 j 300)  NN 

C USER  WANTS  OUT  -> 

900  EXIT  = 0 
RETURN 

C FORMAT  STATEMENTS 

1000  F0RMAT(13A2.*44  (.•f)y/y26X9*fj 

&10X»  “STANDARD  EXPECTAT  IONS  * yllXf'f,/, 

S26X.44  ),/,26Xy  “ :«cCROP)t:  * j 2X  > 

^'RATIME*  r2X?  ‘)f^WILD)«:*  r2X»  ‘WATERS  »3X> 

&‘)«cHI6H)JcGTHER:^“  j/y26Xy 

&*)|JLAND:^MEGETATI0N){cLIFE5fcRECREATI0N)|iUSE  ,5X>  ’f) 

C 

1020  FORMAT  <70  < ' )fc  “ ) » / » 26X y ' 5tc • 4X “ ‘ lOX * ){c ' 4X ' « - lOX ' “ 4X  * - 5X • * “ ) 
C 

1050  FORMAT (13A2» 

rAXj-f’  y lOXy  "t.’  yAXf  ' • , lOX  » * * ' » 4X  j "fy^Xy^f) 

C 

1051  F0RMAT(2X»I2»llA2y 

;S'){c'  ,4Xy  •)«(•>  lOXy  "Jlc"  »4X»  •51:*'  > lOXf  •)((•  >4X ?•)(«•  »5Xf  ) 

C 

1100  FORMAT <13A2t 

•'11“  5fc  “11“  t “11“  5fc  -II-  t “11“  t 

C 

1200  FORMAT  </*YOU  HAOE  TYPED  IN  AN  ILLEGAL  ANSWER* “y 


“11“  ^“) 


X/ 


GIVE  FiER  ANOTHER  SHOT 


) 


C 


C 


c 


c 


r. 


2000  FORMATCENTER  THE  APPROPRIATE “ y 5X y 

&44  ( “5|c"  ),/,* NUMBER y OR  ZERO  TO  QUIT  ->  _“) 

1010  F0RMAT(17X“INPUT  RESPONSES/ANIMALS “// ) 

k 

2010  F0RMAT(17X“EDIT  RESPONSES/ANIMALS*//) 

b. 

3010  F0RMAT(17X“EDIT  EXPECTATIONS/ANIMALS “ // ) 

2020  F0RMAT(5X“IN  WHICH  HEADING  IS  YOUR  DESIRED  EDlT?“/y 
&5X“  (ENTER  AyByCy  OR  NONE)  ~>  _“) 

2030  FORMAT <A2) 

2040  FORMAT <5X“ YOUR  CURRENT  RESPONSE  IS  “>‘I2y//y 
&5X“ENTER  YOUR  NEW  RESPONSE  HERE  ->  ^“) 

3020  F0RMAT(5X“IN  WHICH  SUB-HEADING  IS  THE  EXPECTATION  OALUE“/y 

&5X“Y0U  WISH  TO  CHANGE?  (ENTER  THE  APPROPRIATE  NUMBER)->  _') 

3030  FORMAT (/5X“ SELECT  THE  LAND  USE  OPTION  YOU  WISH  TO  CHANGE “/ 

.>  1X“  -1-  / -2-  / “3~  / -4-  / -5“  / -6-  /V 

> 1X“CR0PLAND/NAT *0EG*/WILDLIFE/WAT*RECv/HI6H  USE/  OTHER/' 
>/5X"ENTER  YOUR  SELECTION  HERE  ~>  -‘) 


C 


3040  FORMAT (5X“ ENTER  YOUR  NEW  EXPECTATION  OALUE  HERE 


) 


C 


3050  FORMAT  (/y  5X“ ERROR — > YOUR  EXPECTATION  OALUE  MUST  BE“/y 
%5X“0?iy2y3y  OR  4 TO  AOGID  INTRODUCING  A BIAS  ->  _“) 


C 
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0279 

0280 
0281 
0282 
0283 


3060  F0rmAT(5X-ANy  MORE  EDITS  TO  ANIMALS  ?'  .. 
&5X"  (YES  OR  NO)  ~> 

C 

END 

END$ 
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T=00004|  IS  ON  CR00015  USING  00018  8LKS  R=0015 

I 

FTN4 

SUBROUTINE  AXES  (IXrIY»XMIN) 

C 

C LEVEL  5 
C 

C SUBROUTINE  AXES  IS  ACCESSED  BY  GRAFS  TO  DRAW  IHE  AXES  FOR 
C THE  DRAGLINE  GRAPHS 
C 

C THE  CALLING  SEQUENCE  ISJ 
C 

C CALL  AXES  (IX^IYjXMIN) 

C 

C WHERE 
C 

C IX  IS  THE  ABSOLUTE  X SCREEN  COORDINATE  OF  THE  GRAPH'S  ORIGIN 

C lY  IS  THE  ABSOLUTE  Y SCREEN  COORDINATE  OF  THE  GRAPH'S  ORIGIN 

C XMIN  IS  THE  MINIMUM  X VALUE  TO  BE  DISPLAYED 

C 

C AXES  USES  THE  TCS  ROUTINES  t ANMOD»DRAWAf DRWRL>MOVABf 
C MOVE A f AND  MOVRL 

C AND  DECLARES  LABEL  COMMON  TABLE* 

C 

C THIS  ROUTINE  WAS  WRITTEN  BY  EASTMAN/GREEN 
C 

C CLAIM  RELEASE  1*0  - APRIL  If  1980 

C 

C 

C TEKTRONIX  COMMON 

C 

COMMON  ITEK  (45) 

C 

C LOGICAL  UNITS  AND  COMMON  LOCATION 

C 

COMMON  IARRY(5) ? IARY2 ( 5) ? LER j LUF r LUL 
C 

C POINTERS 

C 

COMMON  EXIT  ? IANM<3) ? ICLI (2) » IGEN(3) » I6RW(5) 

COMMON  lOPTN  »I0VR(7) r IPNTR  y IS0C(6) y I SUB (8) 

COMMON  ISUR(6) y 1T0PC9) y 1VE6(2) yLEXIT  yLUO 
COMMON  MODE  yNANM  yNCLI  yNGEN  yNGRW 

COMMON  NOVR  yNSECTS  yNSOC  yNSUB  yNSUR 

COMMON  NTOP  yNU  yNVEG 

C 

C GRADING  PARAMETERS 

C 

COMMON  AREA ( 5 ) y BENLEN ( 5 y 1 0 ) y BENWI < 5 y 1 0 ) y C060  y GCPA  < 5 ) 

COMMON  6RDVBS(5) yMUHTCSy 10) vHWSLI (5y 10 ) y NSPP ( 5 ) y PCE019 ( 4 ) 
COMMON  PERCNT(5y 10) yREHCPY<5) y REHVOL ( 5 ) ? SLOPE ( 5 y 10 ) y WBP 
C 

C CATEGORY  TEXT 

C 

COMMON  ANIM<23y 13) » CLMA( 13y 13) y GDES( 15y 13) y GWHY(22y 13) 
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0055 

0056 

0057 

0058 

0059 

0060 

0061 

0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 

0081 

0082 

0083 

0084 

0085 

0086 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0093 

0099 

0100 

0101 

0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


I 


' j COHHON  00BD(11t13) f SBSL(13) » SCEC<33> 13) y SWHY(44y 13) 
i COHMON  TPSL(495l3) >V6TA(15j 13) 

C 

C EXPECTATION  VALUES 

C 

COMMON  ANIMAL(13j6) ?CLIMAT<8»6) r6ENDES(8»6) ?GRWHYD<19y6) 
COMMON  0VRBDN(28y6) j S0CECN<29?6) ?SUBS0I(30y6) ?SURHYD(23y6) 
COMMON  T0PS0I(33j6)>VEGETA(10j6) 

C 

C CATEGORY  RESPONSES 

C 


COMMON  RANIMA<3) jRCLIMA<2) yR6ENDE<3) yR6RUHY<5) 
COMMON  RO VRBD ( 7 » 1 0 ) » RSOCEC (6)f RSUBSO < 8 ) y RSURH Y ( 6 ) 
COMMON  RT0PS0<9) yRVEGET(2) 

C 

C FEASIyTECONyOPUSE  SUBSYSTEM  PARAMETERS 

C 

COMMON  CA AHM  y CABAH  y CABFN ( 3 ) y CABFP ( 3 ) y CABHM 

COMMON  CABS  < 2 ) y CAC  y CACP  y C ABF  y CADH 

COMMON  CADS  y C AE AF  y CAHSAF  y CAHSTS  y CA I P 

COMMON  CAR3FC  y CASE  y C ASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y FAV6  < 5 ) y PF  STSP  y PFAC  y RCLTEC ( 29  y 34 ) 

COMMON  TCAR(5) yTHICK(iO) yTHKTSyTTL<40) 

C 

INTEGER 
INTEGER 
INTEGER 
INTEGER 
INTEGER 
INTEGER 
INTEGER 
INTEGER 
C 

INTEGER  COMMON  (1) 


EQUIVALENCE 

(COMMON 

(1) 

y ITEK 

EQUIVALENCE 

(lARRY 

(1)  y 

LUT) 

EQUIVALENCE 

(1ARY2 

(1)  y 

ISTRK) 

EQUIVALENCE 

(IARY2 

(2)  y 

ISECT) 

EQUIVALENCE 

(1ARY2 

(3)  y 

I CODE) 

EQUIVALENCE 

(IARY2 

(4)  y 

LEN) 

C 

LOGICAL  LER 


C 

COMMON  /TABLE/ 

> TBLMy  TBLTy  TBLAr  TBLSy  JCOUNT y TSMIN y KOBE y 

> TSMAX y TMMIN y TVMAX  y TAM IN  y TAM AX  y TTMI N y TTMAX 
C 

DIMENSION  TBLV<12) y TBLT(12) y TBLA(12) yTBLS(12) 

C 

LUB  = IARRY(3) 

C 

CALL  MOVABClXyiY) 

BO  100  I==lyiO 
CALL  BRWRL(30y0) 


EX I T y CLMA  y GDES  y GWH Y y OVBB  y SBSL 
SCEC  y SUF-IY  y TPSL  y OGTA  y ANIM 
CL IMAT  y 6ENBES  y 6RWH YB  y OMRBDN 
SOCECNy SUBSOI y SURHYBy TOPSOl 
VEGETAyANIHAL 

RCLI MA  y RGENDE  y RGRWHY  y ROMRBB  y RSOCEC 
RSUBSO  y RSURHYy  RTOPSO  y RVEGET  y RANIMA 
RCLTECyTTL 
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0111 

0112 

0113 

011^ 

0115 

0116 

0117 

0118 

0119 

0120 
0121 
0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 


CALL  M00RL(0?-5) 

CALL  HRWRL(OylO) 

100  CALL  M00RL<0»~5) 

CALL  hOOABdXrlY) 

HO  200  I=lpJCOUNr 

CALL  DRAWA(XMIN  jTBLS(D) 

CALL  M00RL(5  ?0  ) 

CALL  DRllRL(~10r0  ) 

CALL  H00RL(-75  y-3) 

CALL  ANMOD 

WRITE (LUD» 1010)  TBLS(I) 

1010  F0RMAT(F5*1) 

CALL  M0VEA<XMIN>TBLS(1)) 

200  COMTINUE 
C 

CALL  M00AB<IX+5f IY+310) 

CALL  ANMOD 
WRITE(LUB? 1020) 

1020  FORMAK 'FINAL  SLOPE  (DEGREES)") 

CALL  N00AB(IX-25y IY-20) 

CALL  ANMOD 
ZER0===0* 

IF(XMIN*NE.O* ) WRITE(LUBy 1030)  XMIN 
IF(XMIN*EQ*0^ ) WRITE(LUD» 1031 ) ZERO 

1030  FORMAT <F9* 2) 

1031  F0RMAT<F3*1) 

RETURN 

END 

END$ 
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SBLiILD  T=00004  IS  ON  CR00015  USING  00023  BLKS  R=0012 


0001  FTN4 

0002  SUBROUTINE  BUILD 

, 0003  C 

0004  C LEOEL  4 

0005  C 

0006  C BUILD  IS  ACCESSED  BY  DLRE  TO  BUILD  TABLES 

0007  C OF  THE  DRAGLINE  FINAL  SLOPE  RELATIONSHIPS* 


0008  C 

0009  C THE  CALLING  SEQUENCE  IS  I CALL  BUILD 

0010  C 


0011 

C 

SUBROUTINE 

S SCHEDULED  BY  BUILD  ARE 

J 

0012 

C 

' 

0013 

C 

DLGCO 

TO  COMPUTE  THE  VOLUMES 

AND 

COSTS 

OF 

GRADING 

FOR 

THE 

0014 

C 

OPENING  CUT  OPTION 

0015 

C 

DLGCM 

TO  COMPUTE  THE  VOLUMES 

AND 

COSTS 

OF 

GRADING 

FOR 

THE 

0016 

C 

MINE  RUN  OPTION 

0017 

c 

DLGCF 

TO  COMPUTE  THE  VOLUMES 

AND 

COSTS 

OF 

GRADING 

FOR 

THE 

0018 

c 

FINAL  CUT  OPTION 

0019 

c 

MNMXF 

TO  DETERMINE  THE  MINIMUM  AND  MAXIMUM 

FINAL 

SLOPE 

VALUES 

0020  C 

0021  C BUILD  USES  THE  TCS  ROUTINES  : BELL  AND  TINPT 

0022  C 

0023  C THE  LOCAL  OARIABLES  AREi 

0024  C 


0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 


C 

C 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


•CPAC"  - 
"CST' 
*ICHAR*  - 
•I PASS*  - 
•KCODE"  - 
• SLOPE J'- 
'SLPINT*- 
•TLSE*  - 
•OOL* 
*UID" 


THE  COST  PER  ACRE  (DOLLARS/ACRE) 

COST  OF  GRADING  (DOLLARS) 

TINPT  RETURN  CELL 

SET  TO  ZERO  FOR  FIRST  PASS?  ONE  FOR  FINAL  PASS 

AS  DEFINED  IN  MNMXF 

FINAL  SLOPE  VALUE  (IN  DEGREES) 

SLOPE  INTERVAL  (IN  DEGREES) 

HYPOTHETICAL  TOTAL  LENGTH  OF  MINE  RUN  SPOILS  (IN  FEET) 
VOLUME  GRADED  (IN  CUBIC  YARDS) 

WIDTH  OF  THE  FINAL  SPOIL  BANK  FOR  THE  OPENING  CUT 
IN  FEET* 


THIS  ROUTINE  WAS  WRITTEN  BY  EASTMAN/GREEN 

CLAIM  RELEASE  1*0  — APRIL  1?  1980 


TEKTRONIX  COMMON 


0045  COMMON  ITEK  (45) 

0046  C 

0047  C LOGICAL  UNITS  AND  COMMON  LOCATION 

0048  C 

0049  COMMON  IARRY(5) y I ARY2 ( 5 ) y LER ? LUF j LUL 

0050  C 

0051  C POINTERS 

0052  C 

0053  COMMON  EXIT  y 1 ANH ( 3 ) y ICLI ( 2 ) y IGEN ( 3 ) y IGRW ( 5 ) 

0054  COMMON  lOPTN  y lOVR ( 7 ) y IPNT R y I SOC ( 6 ) y I SUB ( 8 ) 
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0055 

0056 

0057 

0058 

0059  C 

0060  C 

0061  C 

0062 

0063 

0064 

0065  C 

0066  C 

0067  C 

0068 

0069 

0070 

0071  C 

0072  C 

0073  C 

0074 

0075 

0076 

0077  C 

0078  C 

0079  C 

0080 
0081 
0082 

0083  C 

0084  C 

0085  C 

0086 

0087 

0088 

0089 

0090 

0091 

0092  C 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 

0101  C 

0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109  C 

0110 


COMMON  ISUR<6) > IT0P<9) » I0EGC2) yLEXIT  »LUO 
COMMON  MODE  jNANM  »NCLI  »N6EN  tNGRW 

COMMON  NOME  >NSECTS  >NSOC  >NSUB  yNSUR 

COMMON  NTOP  »NU  >NOEG 

GRADING  PARAMETERS 

COMMON  ARE A ( 5 ) y BENLEN ( 5 y 1 0 ) y BENW I ( 5 y 1 0 ) ? COGO  y GCPA ( 5 ) 

COMMON  GRDOBS ( 5 ) y HWHT ( 5 y 1 0 ) y HWSL I < 5 y 1 0 ) y NSPP ( 5 ) y PCEQ 1 9 < 4 ) 
COMMON  PERCNT(5y 10) yREHCPY<5) yREH00L(5) ySL0PE<5y 10) yWBP 

CATEGORY  TEXT 

COMMON  ANIM(23y 13) yCLMA< 13y 13) y6DES( 15y 13) yGUHY(22y 13) 
COMMON  00BD(llyl3)ySBSL(13)y  SCEC ( 33 y 13 ) y SWHY < 44 y 13 ) 

COMMON  TPSL(49y 13) yOGTA(15y 13) 

EXPECTATION  VALUES 

COMMON  ANIMAL ( 1 3 y 6 ) y CL I MAT ( 8 y 6 ) y GENDES ( 8 y 6 ) y GRWH YD  < 1 9 y 6 ) 
COMMON  0VRBDN<28?6) y S0CECN(29y 6) ySUBSOI (30y6) ySURHYD(23y 6) 
COMMON  TOPSOI(33y6) y VEGETA(10y6) 


CATEGORY  RESPONSES 


COMMON  RAN I MAC  3) y RCLIMA ( 2 ) y RGENDE < 3 ) yRGRUHYCS) 
COMMON  R0VRBD(7y 10) yRS0CEC(6) yRSUBSO(B) y RSIIRHY(6) 
COMMON  RT0PS0<9) yRVE6ET(2) 

FEASIyTECONyOPUSE  SUBSYSTEM  PARAMETERS 


COMMON  CAAHM  y CABAH  y CABFN ( 3 ) y CABFP ( 3 ) y CABHM 

COMMON  CABS ( 2 ) y C AC  y CACP  y CADF  y CADH 

COMMON  CADS  r CAEAF  y CAHSAF  y CAHSTS  y CA I P 

COMMON  CAR3FC  y CASE  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y FAVG  < 5 ) y PFSTSP y PFAC  y RCLT  EC ( 29  y 34 ) 

COMMON  TCAR(5) yTHICK(lO) yTHKTSyTTL(40) 

INTEGER  EXI T y CLMA y GDES y GWHY  y OMBD y SBSL 
INTEGER  SCEC  y SUHY  y TPSL  y VGTA  y ANIM 
INTEGER  CLIMATy GENDES yGRWH YD yOVRBDN 
INT  EGER  SOCECN  y SUBSOI y SURHYD  y TOPSOI 
INTEGER  VEGETA y ANIMAL 

INTEGER  RCL I MA  y RGENDE  y R6RUHY  y ROVRBD  y RSOCEC 
INTEGER  RSUBSO  y RSURHY  y RTOPSO  y RVEGET  y RANIMA 
INTEGER  RCLTECyTTL 


INTEGER  COMMON  (1) 
EQUIVALENCE  (COMMON 
EQUIVALENCE  (lARRY 
EQUIVALENCE  (1ARY2 
EQUIVALENCE  (IARY2 
EQUIVALENCE  (IARY2 
EQUIVALENCE  (IARY2 


<l)y  ITEK 

(1) y  LUT) 
<l)y  ISTRK) 

(2) y  I SECT) 
<3)y  ICODE) 
<4)y  LEN) 


(1)  ) 


LOGICAL  LER 
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0111 

0112 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120 
0121 
0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 
0161 
0162 

0163 

0164 


C 

C ======  = ===:==========  = ==  = =========:=:  = =:  = =========:===========:=:  = ==^  = =====:  = ====u:=:===:  = =:===r=.r:=:==rr:=====::=z.=: 

c 

c 

CDMHON  /TABLE/ 

> TBLO>  TBLTt  TBLA»  TBLSj  JCOUMT ? TSHIN ? KOBE ? 

> 1 SMAX , TMMIN  > TMMAX  r T AMI N ? T AMAX  j TTMI H f T TMAX 
C 

DIMENSION  TBLM(12) yTBLT<12) tTBLA(12) ,TBLS(12) 

C 

1PASS=0 

C DETERMINE  THE  MINIMUM  AND  MAXIMUM  FINAL  SLOPE  VALUE 

KC0DE=1 

CALL  MNMXF ( LUT » MODE » R6ENDE ( 2 ) f 6RDVBS  r TSMAX  y TSMI N y KCODE ) 
1F(KC0DE.NE*3)  GOTO  10 
IF(LER)  CALL  BELL 
IF(LER)  WRITE(LUTy37) 

IF(LER)  CALL  TINPT(ICHAR) 

1PNTR=KC0DE 

RETURN 

C DETERMINE  THE  SLOPE  INTERVAL  AND  SET  ABSOLUTES 

10  SLPINT  = FLOAT  < IFIX  < TSMAX-TSMIN ) ) / 10* 

IF<SLPINT*LT*0»i)  SLPINT  =0.1 
TVMAX  = 0. 

TTMAX  = 0. 

TAMAX  = 0. 

TVMIN  = 1.0E36 
TTMIN  = 1.0E36 
TAM IN  = 1.0E36 

C COMPUTE  THE  VALUES 

JCOUNT  = 0 
SLOPJ  = TSMIN  + .01 
50  JCOUNT  = JCOUNT  + 1 

GOTO  <100^200? 300)  RGENDE<2) 

100  CALL  DLGCO  ( SLOP Jy 100 ♦ y VOL y CST ? CPAC y GRDVBSt C060 r UID ) 

GOTO  400 

200  CALL  DLGCM  (SLOPJy 100. y VOLyCSTy TLSByGRDVBSyCOGO) 

GOTO  400 

300  CALL  DLGCF  (SLOPJy 100. yWBP yGRDVBS? LOGO y VOLyCSTy ACRES) 

400  IF ( TBL V < JCOUNT ) ♦ 6T . TVMAX ) T VHAX=TBLV ( JCOUNT ) 

IF (TBLV( JCOUNT) .LT. TVMIN)  TVMIN=TBLV < JCOUNT ) 

IFdBLTC  JCOUNT  ) .GT.  TTMAX)  TTMAX=TBLT  < JCOUNT  ) 

IF(TBLT( JCOUNT) .LT. TTMIN)  TTMIN=TBLT < JCOUNT ) 

IF ( TBLA ( JCOUNT ) ♦ 6T . T AMAX ) TAMAX=TBLA ( JCOUNT ) 

IF(TBLA( JCOUNT) .LT.TAMIN)  TAHIN=TBLA ( JCOUNT ) 

SLOPJ  = SLOPJ  T SLPINT 

IF  < SLOPJ . LE . T SMAX-SLPI NTT ♦ 1 ) GOTO  50 
IF(IPASS<EQ.l)  RETURN 
1PASS=1 
SLOPJ=TSMAX 
GOTO  50 

37  FORMAT </5X‘HIT  THE  RETURN  KEY  TO  CONTINUE...-) 

END 

ENDT 
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SCATiC  1=0000'^  IB  ON  CR00015  USING  00024  BLKS  R=0000 


0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 

0053 

0054 


FTN4 


C 


SUBROUTINE  CATIO 

ABBREOIATEB  DISPLAY — CATEGORY  10  / SOCIO-ECONOMICS 


C 

C LEVEL  2 
C 

C CATIO  IS  ACCESSED  BY  EIAD  TO  SCHEDULE  INPUTS  TO  THE  CATEGORY 
C RESPONSES  IN  CATEGORY  X - SOCIO-ECONOMICS » USING  ABBREVIATED  DISPLAY 
C 

C THE  CALLING  SEQUENCE  IS  : CALL  CATIO 

C 

C 

C THIS  ROUTINE  WAS  WRITTEN  BY  EASTMAN  AND  MODIFIED  BY  GREEN 
C 

C CLAIM  RELEASE  1»0  - APRIL  Ir  1980 

C 

C TEKTRONIX  COMMON 

C 

COMMON  ITEK  <45) 

C 

C LOGICAL  UNITS  AND  COMMON  LOCATION 

C 

COMMON  IARRYC5) ? I AR Y2 ( 5 ) ? LER ? LUF ? LUL 
C 

C POINTERS 

C 

COMMON  EXIT  > IANMC3) j ICL1<2) r I6EN(3) r IGRW<5) 

COMMON  lOPTN  j I0VR(7) » IPNTR  y ISOC ( 6 ) y I SUB ( 8 ) 

COMMON  ISUR<6) y 1T0P(9) y IVE6(2) yLEXIT  yLUO 
COMMON  MODE  yNANM  yNCLI  yNGEN  yNGRW 

COMMON  NOVR  yNSECTS  yMSOC  yNSUB  y NSUR 

COMMON  NT  OP  yNU  yNVEG 

C 

C GRADING  PARAMETERS 

C 

COMMON  AREA(5) yBENLEN(5y 10) yBENWI (5y 10) yC060yGCPA(5) 

COMMON  6RDVBS(5) y HWHT ( 5 y 1 0 ) r HWSLl ( 5y 10) y NSPP<5) y PCEQ19(4 ) 

COMMON  PERCNT(5y 10) yREHCPY<5) y REHVOL < 5 ) y SLOPE < 5 y 10 ) y WBP 
C 

C CATEGORY  TEXT 

C 

COMMON  AN I M < 23  f 1 3 ) y CLMA ( 1 3 y 1 3 ) y GDES  < 1 5 y 1 3 ) y GWH Y < 22  y 1 3 ) 

COMMON  0VBD(llyl3)ySBSL<13)y  SCEC(33y 13) y SWHY(44 y 13) 

COMMON  TPSL(49y 13) y VGTA<15y 13) 

C 

C EXPECTATION  VALUES 

c: 

COMMON  AN I MAL  < 1 3 y 6 ) y CL I M AT ( 8 y 6 ) y 6ENDES ( 8 y 6 ) y GRWH YD ( 1 9 y 6 ) 

COMMON  0VRBDN<2Sy6) yS0CECN(29y6) ySUBSOI (30y6) y SURHYD ( 23 y 6 ). 

COMMON  TOPSOI ( 33  y 6 ) y VEGETA ( 1 Oy  6 ) 

C 

C CATEGORY  RESPONSES 

C 
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0055 
I 0056 
j 0057 
^ 0058  C 

i 0059  C 
I 0060  C 
! 0061 
: 0062 
I 0063 

0064 

0065 

0066 

0067  C 

0068 

0069 

0070 
^ 0071 

, 0072 

0073 

0074 

0075 

0076  C 

, 0077 

I 0078 
0079 

I 0080 
* 0081 
I 0082 

I 0083 
1 0084  C 

I 0085 
I 0086  C 
I 0087  C 

I 0088 

I 0089 
I . 0090  C 
^ 0091 

, 0092 

0093 
: 0094 

0095 

0096 

0097  C 

0098 

0099 

0100 
0101 
0102 

0103 

0104  C 

0105 

0106 

0107 

0108 

0109 

0110 


COMMON  RANIMA<3) fRCLlMA<2) yRGENIiE<3) yR6RUHY<5) 
COMMON  R00RBD(7yl0) »RS0CEC(6) jRSUBS0(8) >RSURHY(6) 
COMMON  RT0PS0<9) tROECET (2) 


FEASIf TECONfOPUSE  SUBSYSTEM  PARAMETERS 


COMMON  CAAHM » CABAH  > CABFN ( 3 ) j CABFP ( 3 ) » CABHM 

COMMON  CABS  < 2 ) > CAC  ? CACP » CADF  > CADH 

COMMON  CADS  y CAE AF » CAMS AF » CAUSTS  ^ CA I P 

COMMON  CAR3FC  j CASF  t CASNC  > CSTES y CSTRM 

COMMON  CSTRP  > FA06 ( 5 ) ? PFSTSP  j PF AC  j RCLTEC  < 29  > 34 ) 

COMMON  ICAR (5) i THICK (10) > THKTS > TTL ( 40 ) 


INTEGER  EXI T » CLMA » GDES » 6UHY  ? OOBD  j SBSL 
INTEGER  SCEC  y SWHY  y TPSL  r 06TA  y ANIM 
INTEGER  CLIMATyGENDESyGRWHYDyOORBDN 
INTEGER  SDCECNySUBSOIySURHYDyTOPSOI 
INTEGER  VEGETA y ANIMAL 

INTEGER  RCLI MA  y R6ENDE  y R6RUH Y y RDVRBD  y RSOCEC 
INTEGER  RSUBSO  y RSURHY  y RTOPSO  y RVEGET  y RANIHA 
INTEGER  RCLTEC yTTL 


INTEGER  COMMON  (1) 

EQUIVALENCE  (COMMON  (l)y  ITEK  (D) 


EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 


(lARRY 

(1ARY2 

(IARY2 

(IARY2 

(1ARY2 


(1)  y 

(1)  y 

(2)  y 

(3)  y 
( 4 ) y 


LUT) 
ISTRK) 
I SECT) 
I CODE) 
LEN) 


LOGICAL  LER 


DU7PUT  HEADING 

WRITE  (LUTylOOO)  (SCEC  (lyJ)y  J = iyl3) 

GOTO  (10y20y 30y40y50y60)  LEXIT 

USER  INPUT  ~>  ARCHAEOLOGIC  SITES 
10  WRITE  (LUTylOSO)  ((  SCEC  (IrJ)y  J = lyl3)y  I = 2y4) 

READ  (LUTy:^)  RSOCEC  (1) 

IF  (RSOCEC  (1)*EQ»0)  RETURN 

IF  (RSOCEC  (1) ♦GE»1 .AND. RSOCEC  (l).LE.ISOC  (1))  GOTO  20 
WRITE  (LUTyi015)  RSOCEC  (1) 

GOTO  10 

USER  INPUT  ->  PRESENT  LAND  USE 
20  WRITE  (LUTyi020)  (<  SCEC  (lyJ)y  J = lyl3)y  I = 7y8) 

READ  (LUT?)fO  RSOCEC  (2) 

IF  (RSOCEC  (2).EQ.0)  RETURN 

IF  (RSOCEC  (2) .GE.i. AND. RSOCEC  (2).LE.IS0C  (2))  GOTO  30 
WRITE  (LUTyl015)  RSOCEC  (2) 

GOTO  20 

USER  INPUT  ->  SECONDARY  LAND  USE 
30  WRITE  (LUfylOlO)  (SCEC  (17yJ)y  J = lyl3) 

READ  (LUTy)^)  RSOCEC  (3) 

IF  (RSOCEC  (3).EQ.0)  RETURN 

IF  (RSOCEC  (3) .BE. 1 .AND. RSOCEC  (3).LE.IS0C  (3))  GOTO  40 
WRITE  (LUTylOlS)  RSOCEC  (3) 

GOTO  30 
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0111 

0112 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120 

0121 

0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 


40 


C 


C 


C 


50 


60 


C 
C 
C 
C 
C 
C 

1060 

C 

l£ND$ 


1000 


1010 


1015 


1020 


1050 


USER  INPUT  ~>  FUTURE  LAND  USE  DESIRE  OF  OWNER 
WRITE  (LUT^IOSO)  <(SCEC  <I>J)y  J = 1,13)?  I - 24,26) 

READ  <LUT,)*c)  RSOCEC  <4) 

IF  (RSOCEC  <4)*EQ*0)  RETURN 

IF  (RSOCEC  (4) ♦GE, 1 ♦AND*RSOCEC  (4)*LE*IS0C  (4))  GOTO  50 
WRITE  (LUT,1015)  RSOCEC  (4) 

GOTO  40 

USER  INPUT  ->  FUTURE  LAND  USE  DESIRE  OF  COMMUNITY 
WRITE  (LUT,1050)  ((  SCEC  (I,J),  J = 1,13),  I = 27,29) 

READ  (LUT,)^:)  RSOCEC  (5) 

IF  (RSOCEC  (5)*EQ*0)  RETURN 

IF  (RSOCEC  (5) ♦GE.l* AND ♦RSOCEC  (5)*LE*ISCC  (5))  GOTO  60 
WRITE  (LUT,1015)  RSOCEC  (5) 

GOTO  50 

USER  INPUT  ->  FUTURE  LAND  USE  DESIRE  OF  GOVERNMENT 
WRITE  (LUT,1060)  ((  SCEC  (I,J),  J = 1,13),  I = 30,33) 

READ  (LUf,)fO  RSOCEC  (6) 

IF  (RSOCEC  (6) ♦GEfOtAND.RSOCEC  (6)*LE»IS0C  (6))  RETURN 
WRITE  (LUT,1015)  RSOCEC  (6) 

GOTO  60 

FORMAT  STATEMENTS 
FORMAT  (/5X,13A2) 


FORMAT  (/5X,13A2"  ->  _') 

FORMAT  (A2*  ??  ->  RE-INPUT*") 

FORMAT  (/5X,13A2,  /5X,13A2"  ->  _") 
FORMAT  (2(/5X,13A2)  ,/5X,13A2*  ->  _") 

FORMAT  (3(/5X,13A2)  ,/5X,13A2"  ->  _") 
END 
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&CAT2 


I 


0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 

^ 0022 
0023 
^ 0024 

0025 

i 0026 

1 0027 

I 0028 
I 0029 
^ 0030 

I 0031 
^ 0032 

] 0033 

: 0034 

i 0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 

0053 

0054 
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FTN4 

SU8R0UTINL'  CAT2 

C ABBREOIATED  DISPLAY — CATEGORY  2 / CLIMATOLOGY 

C 

C LEVEL  2 
C 

C CAT2  IS  ACCESSED  BY  EIAD  TO  SCHEDULE  INPUTS  TO  THE  CATEGORY 
C RESPONSES  IN  CATEGORY  II  - CLIMATOLOGY?  USING  ABBREVIATED  DISPLAY 
C 

C THE  CALLING  SEQUENCE  IS  i CALL  CAT2 

C 

C THIS  ROUTINE  WAS  WRITTEN  BY  EASTMAN  AND  MODIFIED  BY  GREEN 
C 

C CLAIM  RELEASE  1*0  - APRIL  1?  1980 

C 

C TEKTRONIX  COMMON 

C 

COMMON  ITEK  (45) 

C 

C LOGICAL  UNITS  AND  COMMON  LOCATION 

C 

COMMON  IARRY<5) ? 1 ARY2 ( 5 ) ? LER ? LUF ? LUL 
C 

C POINTERS 

C 

COMMON  EXIT  ? 1 ANM < 3 ) ? ICLI < 2 ) ? IGEN ( 3 ) ?I6RW(5) 

COMMON  lOPTN  y lOVR ( 7 ) ? IPNTR  y IS0C<6) y ISUB<8) 

COMMON  ISUR<6) y IT0P(9) y I VEG ( 2 ) y LEXI T yLUO 
COMMON  MODE  yNANM  yNCLI  yNGEN  y N6RW 

COMMON  NOVR  yNSECTS  yNSOC  yNSUB  y NSUR 

COMMON  NTOP  yNU  y NVEG 

C 

C GRADING  PARAMETERS 

C 

COMMON  AREA (5) y BENLEN < 5 y 10 ) y BENUI ( 5 y 10 ) y COGO y GCPA ( 5 ) 

COMMON  GRDVBS  < 5 ) y HWHT  < 5 y 10 ) y HWSL 1 < 5 y 10 ) y NSPP  < 5 ) y PCEQ 19(4) 
COMMON  PERCNT ( 5 y 1 0 ) y REHCPY ( 5 ) y REHVOL ( 5 ) y SLOPE ( 5 y 1 0 ) y WBP 
C 

C CATEGORY  TEXT 

C 

COMMON  ANIM(23y  13)  yCLMA(13y  13)  yGDESdSy  13)  yGWHY(22y  13) 

COMMON  OVBDdly  13)  ySBSL(13)  y SCEC  ( 33  y 1 3 ) y SWH  Y ( 44  y 13  ) 

COMMON  TPSL(49y 13) y VGTA(15y 13) 

C 

C EXPECTATION  VALUES 

C 

COMMON  ANIMAL(13y6) yCLIMAT(8y6) yGENDES(Sy6) yGRWHYD(19y6) 
COMMON  0VRBDN(28y6) yS0CECN(29y6) ySUBS0I(30y6) ySURHYD(23y6) 
COMMON  T0PS0I(33y6) yVE6ETA(10y6) 

r* 

U' 

C CATEGORY  RESPONSES 

C 

COMMON  RANIMA(3) y RCL1MA(2) y RGENDE ( 3 ) y R6RWHY ( 5 ) 
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i 


0055 

0056 

0057 

0058 

0059 

0060 

0061 

0062 

0063 

006-1 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 

0081 

0082 

0083 

0084 

0085 

0086 

0087 

0088 

0089 

009.0 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 

0101 

0102 

0103 

0104 

0105 

0106 

0X07 

OiOB 

CIO? 

0110 


C 

C 

C 


c 


c 

c 

c 


c 


10 


c; 


20 


c 

500 


c 

1000 


c 

1015 

c 


COHMON  F-‘OORBD  < 7 y 1 0 ) y RSOCEC  ( 6 ) y RSUBSO  ( 8 ) y RSURH Y ( 6 ) 
RTDPS0<9)  yRVEGET(2) 


FEASIyTECONyOPUSE  SUBSYSTEM  PARAMETERS 

COMMON  CAAHM  y CABAH  y CABFN ( 3 ) y CABFP ( 3 ) y CABHM 

COMMON  CABS ( 2 ) y CAC  y CACP  y CADF  y CADH 

COMMON  CABS  y CAEAF  y CAHSAF  y CAHSTS  y CAIP 

COMMON  CAR3FC  y CASF  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y FAOG  C 5 ) y PFSTSP  y PFAC  y RCLTEC ( 29  y 34 ) 

COMMON  TCAR(5) yTHICK(lO) y THKTS y TTL ( 40 ) 


INTEGER  EXIT?  CLMA  y GOES  y GWHY  y OOBD  y SBSL 
INTEGER  SCEC  y SWH Y y TPSL  y OGTA  y ANIM 
IN  I EGER  CL I MAT  y GENBES  y GRWHYD  y OORBDN 
INTEGER  SOCECNySUBSOI ySURHYBy  TOPSOI 
INTEGER  OEGETAyANIMAL 

INTEGER  RCL IMA  y R6ENDE  y RGRUH Y y ROORBB  y RSOCEC 
1 N I EGER  RSUBSO  y RSURH Y y RTOPSO  y ROEGET  y RANIMA 
INTEGER  RCLTECyTTL 


INTEGER  COMMON  (1) 

EQUIVALENCE  (COMMON  (l)y  ITEK  (D) 


EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 


(lARRY 

(IARY2 

(IARY2 

(IARY2 

(IARY2 


<1)  y 

(1)  y 

(2)  y 

(3)  y 

(4)  y 


LU7  ) 

ISTRK) 

ISECT) 

XCODE) 

LEN) 


LOGICAL  LER 


OUTPUl  HEADING 

WRITE  (LUfylOOO)  ( CLMA  (lyJ)y  J = iy  13) 

GOTO  (10y20)  LEXIT 

USER  INPUT  “>  ANNUAL  PRECIPITATION 
WRITE  (LUTyl020)  ((  CLMA  (iyj)y  J ==  lyl3)y  I =2y3) 

READ  (LUTyJjc)  RCLIMA  (1) 

IF  (RCLIMA  (1).EQ*0  ) GOTO  500 

IF  (RCLIMA  (1) .G£.1*AND*RCLIMA  (1)*LE*ICL1  (1))  GOTO  20 
WRITE  (LUTylOlS)  RCLIMA  (1) 

GOTO  10 

USER  INPUT  ->  WIND  VELOCITY 
WRITE  (LUTyl020)  ((  CLMA  (lyJ)y  J = lyl3)y  I ==  8y9) 

READ  (LU'fy3(c>  RCLIMA  (2) 

IF  (RCLIMA  (2).EQ*0)  GOTO  500 

IF  (RCLIMA  (2)  .BE»1«-AND«RCLIHA  (2)*LE.ICLI  (2))  RETURN 
WRITE  (LUTyl015)  RCLIMA  (2) 

{30T0  20 

USER  WANTS  OUT  SET  EXIT  TO  ZERO  AND  RETURN 

EXIT  = 0 
RETURN 

FORMAT  STATEMENTS 
FORMAT  (/5Xyl3A2) 

FORMAT  (A2"  ??  ~>  RE~-INPUT.“) 
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0111 
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0115 


1020  FORMAT  </5Xf  1*3A2/5X>  13A2"  ~> 
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0028 
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0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 
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FTN4 

C ABBREVIATED 

C 

C LEVEL  2 
C 


SUBROUTINE  CAT3 
DISPLAY-“CArEGORY 


3 


/ TOPSOIL 


I 


C CAT3  IS  ACCESSED  BY  EIAD  TO  SCHEDULE  INPUTS  TO  THE  CATEGORY 
C RESPONSES  IN  CATEGORY  III  - TOPSOILy  USING  ABBREVIATED  DISPLAY 
C 

C THE  CALLING  SEQUENCE  IS  : CALL  CAT3 

C 

C THIS  ROUTINE  WAS  WRITTEN  BY  EASTMAN  AND  MODIFIED  BY  GREEN 
C 

C CLAIM  RELEASE  1*0  - APRIL  Ir  1980 

C 

C TEKTRONIX  COMMON 

C 

COMMON  ITEK  (45) 

C 

C LOGICAL  UNITS  AND  COMMON  LOCATION 

C 

COMMON  IARRY(5) y IARY2(5) yLERyLUFyLUL 
C 

C POINTERS 

A 

c 

COMMON  EXIT  y IANM<3) y ICLI (2) y 1GEN(3) y IGRW(5) 

COMMON  lOPTN  y I0VR(7) y IPNTR  y IS0C(6) y ISUB(8) 

COMMON  ISUR<6)  y IT0P(9)  y 1 VEG ( 2 ) y LEXI T yLLiO 

COMMON  MODE  y NANM  yNCLI  yNGEN  yNGRW 

COMMON  NOVR  yNSECTS  yNSOC  yNSUB  yNSUR 

COMMON  NfOP  yNU  yNVEG 

C 

C GRADING  PARAMETERS 

C 

COMMON  AREA (5) y BENLEN ( 5 y 10 ) y BENWI ( 5 y 10 ) y COGO y GCPA ( 5 ) 

COMMON  6RDVBS(5)  yHWH  f (5y  10)  yHWSLKSy  10)  y NSPP < 5 ) y PCEQ19  ( 4 ) 
COMMON  PERCNI <5y 10) yREHCPY(5) yREHV0L<5) y SL0PE(5y 10) y WBP 
C 

C CATEGORY  TEXT 

C 

COMMON  ANIM(23y 13) y CLMA< 13y 13) rGDES( 15? 13) y 6WHY(22y 13) 
COMMON  0VBD(ilyl3)?SBSL(13)y  SCEC(33y 13) y SWHY<44? 13) 

COMMON  TPSL(49yl3)  yVGTAdSr  13) 

C 

C EXPECTATION  VALUES 

C 

COMMON  AN I M AL (1 3 y 6 ) y CL I M A T ( 8 y 6 ) y GENDES ( 8 y 6 ) y GR WH  Y D < 1 9 y 6 ) 
COMMON  OVRBDN ( 28  y 6 ) y SOCECN  < 29  y 6 ) y SUBSOI < 30  y 6 ) y SURH YD  < 23  y 6 ) 
COMMON  T0PS0I(33y6) yVEGETA(10y6) 

C 

C CATEGORY  RESPONSES 

C 


32 


0055 

0056 
005/ 

0058  C 

0059  C 

0060  C 

0061 
0062 

0063 

0064 

0065 

0066 

0067  C 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076  C 

0077 

0078 

0079 

0080 
0081 
0082 
0083 

! 0084  C 

0085 

0086  C 

0087  C 

0088 

0089 

0090  C 

0091  C 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099  C 

0100 
0101 

0102  C 

0103 

0104 

0105  C 

0106 

0107 

0108  C 

0109 

0110 


COMMON  RANIMA(3) yRCLIMA<2) ?RGENDE<3) ?RGRWHY<5) 
COMMON  R0VRBD<7y 10) y RSOCEC ( 6 ) y RSUBSO < 8 ) y RSURHY ( 6 ) 
COMMON  RT0PS0<9) rRVE6ET(2) 


FEASIrTECONrOPUSE  SUBSYSTEM  PARAMETERS 


COMMON  CAAHM  r CABAH  ? CABEN ( 3 ) » CABFP ( 3 ) y CABHM 

COMMON  CABS(2) yCACyCACPyCADFyCABH 

COMMON  CADSyCAEAF  yCAHSAFyCAHSTSyCAIP 

COMMON  CAR3FC  y CASE  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y F AVG ( 5 ) y PFSTSP  y PFAC  y RCLTEC ( 29  y 34 ) 

COMMON  TCAR<5) yTHICK(lO) yTHKTSyTTL<40) 


INTEGER 

INTEGER- 

INTEGER 

INTEGER 

INTEGER 

INTEGER- 

INTEGER 

INTEC3ER 


EX I T y CLMA  y GDES  y GWH Y y OOBD  y SBSL 
SCEC  y SUHY  y TPSL  y 06T A y ANIM 
CLIMAT  y 6ENDES  y GRWHYB  y OURBDN 
SOCECN  y SUBSOI y SURH YB  y TOPSOI 
OEGETAy ANIMAL 

RCL 1 M A y RGENBE  y R6RUH Y y ROORBD  y RSOCEC 
RSUBSO  y RSURH Y y RTOPSO  y ROEGE T y RANI HA 
RCLTEC y I TL 


INTEGER  COMMON  <1) 

EOUIOALENCE  (COMMON  (l)y  ITEK  <1)) 


EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 


(lARRY 

(IARY2 

(IARY2 

(IARY2 

(1ARY2 


<l)y 

<i)y 

(2)  y 

(3)  y 

(4)  y 


LUT) 

ISTRK) 

ISECT) 

ICODE) 

LEN) 


LOGICAL  LER 


10 


15 


20 


OUTPUT  HEADING 

WRITE  (LUfyiOOO)  ( TPSL  <iyJ)y  J = ly  13) 

GOTO  (10y20y30y40y50y60?70y80y90)  LEXIT 

USER  INPUT  ~>  THICKNESS  (CATEGORY) 

(NOT  REQUIRED  FOR  ADM  RUN) 

IF  (IARRY(2) *EQ*3)  GOTO  20 
WRITE  (LUTylOll)  (TPSL  (2yJ)y  J = ly  13) 

READ  (LUTy)fO  RTOPSO  (1) 

IF  (RTOPSO  (1)<EQ.0)  GOTO  500 

IF  (RTOPSO  (1)»6E*1*AND. RTOPSO  ( 1 ) . LE ♦ ITOP ( 1 ) ) GOTO 
WRITE  (LUT y 1015)  RTOPSO  (1) 

GOTO  10 


USER  INPUT  ">  COST  TO  REMOVE  TOPSOIL 


WRITE  (LUTyl016) 

READ  (LUTyJJc)  CSTRM 

USER  INPUT  ->  COST  TO  RESPREAD  TOPSOIL 
WRITE  (LUT y 1017) 

READ  (LUT ft)  CSTRP 

USER  INPUT  ->  ACTUAL  THICKNESS  OF  TOPSOIL 
WRITE  (LUTylOlS) 

READ  (LUTy)^:)  THKTS 

USER  INPUT  ">  PERCENT  ORGANIC  MATTER- 
WRITE  (LUTyl020)  ((TPSL  (lyj)y  J=lyl3)y  1 = 7y8) 
READ  (LUTy:^:)  RTOPSO  (2) 
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33 


mil 

C112 
C113 
(ti.  14 
Oll5  C 
O'  16 
17 

r 

*-  v> 

9 


C 2 C 

0.23 

0^24 

..■■ioc; 

w.'.iU* 

i^26 
0127 
<128 
0i:29  C 
1130 
M31 
X1I32 
XJ133 
0134 
13.35 

ai36  C 

0137 

0138 

0139 

0140 

0141 

0142 

0143  C 

0144 

0145 

0146 

0147 

0148 

0149 

0150  C 

0151 

0152 

0153 

0154 

0155 

0156 

0157  C 

0158 

0159 

0160 
0161 
0162 

0163 

0164  C 

0165 

0166 


IF  (RTOPSO  (2)»EQ^0)  GOTO  500 

IF  (RTOPSO  (2) .6E.1* AND* RTOPSO  (2)*LE*IT0P  (2))  GOTO  30 
WRITE  (LUTrlOlS)  RTOPSO  (2) 

GOTO  20 

USER  INPUT  -.>  TEXTURE 

30  WRITE  (LUTjIOIO)  (TPSL  <12>J)j  J = lfl3) 

READ  <LUTr)fO  RTOPSO  (3) 

IF  (RTOPSO  (3)«.E0i0)  GOTO  500 

IF  (RTOPSO  (3)*6E*1*AND*RT0PS0  (3)*LE*IT0P  <3)>  GOTO  40 
WRITE  (LUT^IOIS)  RTOPSO  (3) 

GOTO  30 

USER  INPUr  -.>  STRUCTURE 

40  WRITE  (LUTyl020)  ((TPSL  (I»J)t  J = lyl3)f  I = 19>20) 

READ  (LUT»)fO  RTOPSO  (4) 

IF  (RTOPSO  (4)*EQ*0)  GOTO  500 

IF  (RTOPSO  (4) *GE*1* AND* RTOPSO  (4)*LE*IT0P  (4))  GOTO  50 
WRITE  (LUT>1015)  RTOPSO  (4) 

GOTO  40 

USER  INPUT  ->  DULK  DENSITY 

50  WRITE  (LUTfl020)  ((TPSL  (lyJ),  J = 1»13)»  I = 24^25) 

READ  (LUfyJfO  RTOPSO  (5) 

IF  (RTOPSO  (5)*EQ*0)  GOTO  500 

IF  (RTOPSO  (5) *6E*1* AND* RTOPSO  (5)*LE*IT0P  (5))  GOTO  60 
WRITE  (LUTylOlS)  RTOPSO  (5) 

GOTO  50 

USER  INPUT  ->  SALINITY 
60  WRITE  (LUTylOlO)  (TPSL  (28tJ)>  J=1t13) 

READ  (LUTy)K)  RTOPSO  (6) 

IF  (RTOPSO  (6)«E0<0)  GOTO  500 

IF  (RTOPSO  (6)  *6E*  1 *ANDcRl[OPSO  (6)*LE*IT0P  (6))  GOTO  70 
WRITE  (LUfyl015)  RTOPSO  (6) 

GOTO  60 

USER  INPUT  ~>  SODIUH  ADSORPITON  RATIO 
70  WRITE  (LUTj1020)  ((TPSL  (I>J)p  J = 1?13)»  I = 34^35) 

READ  (LUT,t)  RTOPSO  (7) 

IF  (RTOPSO  (7)<-EQ*0)  GOTO  500 

IF  (RTOPSO  (7) *GE*1*AND« RTOPSO  (7)*LE*IT0P  (7))  GOTO  80 
WRITE  (LUT?1015)  RTOPSO  (7) 

GOTO  70 

USER  INPUT  ->  AVAILABLE  NITROGEN 
80  WRITE  (LUT,1020)  ((  TPSL  (I?J)>  J = lyl3)>  I = 40y41) 

READ  (LUTf>}i)  RTOPSO  (8) 

IF  (RTOPSO  (8)*EQ*0)  GOTO  500 

IF  (RTOPSO  (8) *6E*1* AND < RTOPSO  (8)*LE*IT0P  (8))  GOTO  90 
WRITE  (LUTyl015)  RTOPSO  (8) 

GOTO  80 

USER  INPUT  ->  AVAILABLE  PHOSPHORUS 
90  WRITE  (LUTyi020)  ((  TPSL  (I?J)y  J = lyl3)y  I = 45^46) 

READ  (LUT?)(<)  RTOPSO  (9) 

IF  (RTOPSO  (9)*E0*0)  GOTO  500 

IF  (RTOPSO  (9)  *GE*1  <•  AND*  RTOPSO  (9)*LE*IT0P  (9))  RETURN 
WRITE  (LUT»1015)  RTOPSO  (9) 

GOTO  90 

USER  WANTS  OUT  ~>  SET  EXIT  TO  ZERO  AND  RETURN 

500  EXIT  =:  0 
RETURN 
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SCAT4  T=00004  IS  ON  CR00015  USING  00027  BLKS  R=0000 


0001  rfN4 

0002  SUBROUTINE  CAT4 

0003  C ABBREVIATED  DISPLAY — CATEGORY  4 / SUBSOIL 


0004 

0005 

0006 
0007 
OOOB 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 
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0026 

0027 

0028 

0029 
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0031 

0032 

0033 

0034 
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0038 
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0040 
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0044 
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0050 
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C 

C LEVEL  2 
C 

C CAT4  IS  ACCESSED  BY  El AD  TO  SCHEDULE  INPUTS  ID  THE  CATEGORY 
C RESPONSES  IN  CATEGORY  IV  - SUBSOIL?  USING  ABBREVIATED  DISPLAY 
C 

C THE  CALLING  SEQUENCE  IS  : CALL  CAT4 

C 

C THIS  ROUTINE  WAS  WRITTEN  BY  EASTMAN  AND  MODIFIED  BY  GREEN 
C 

C CLAIM  RELEASE  1*0  ~ APRIL  1?  1980 

C 

C TEKTRONIX  COMMON 

C 

COMMON  ITEK  (45) 

C 

C LOGICAL  UNITS  AND  COMMON  LOCATION 

C 

COMMON  IARRY(5) f IARY2(5) ?LER?LUF?LUL 
C 

C POINTERS 

C 

COMMON  EXIT  » 1ANM(3) ? ICLI(2) ? I6EN ( 3 ) ? I 6RW < 5 ) 

COMMON  lOPTN  ?10VR(7) » IPNTR  r ISOC ( 6 ) ? ISUB < 8 ) 

COMMON  ISUR(6) y IT0P(9) ? I VE6 ( 2 ) y LEXIT  tLUO 
COMMON  MODE  yNANM  yNCLl  yNGEN  y N6RW 

COMMON  NOVR  yNSECTS  yNSOC  yNSUB  yNSUR 

COMMON  NTOP  yNU  yNVEG 

C 

C GRADING  PARAMETERS 

C 

COMMON  AREA ( 5 ) y BENLEN  < 5 y 1 0 ) y BENWI ( 5 y 10 ) y LOGO  y 6CPA  < 5 ) 

COMMON  GRDVBS(5) yHWHT(5y 10) y HUSLl ( 5 y 10 ) y NSPP ( 5 ) ypCEQ19(4) 
COMMON  PERCNT(5y 10) y REHCPY ( 5 ) y REHVOL ( 5 ) y SLOPE ( 5 y 10 ) y WBP 
C 

C CATEGORY  TEXT 

C 

COMMON  ANIM(23y  13)  y CLMA<  13y  13)  yGDESdSy  13)  yGWHY(22y  13) 
COMMON  OVBD ( 1 1 y 1 3 ) y SBSL ( 1 3 ) y SCEC  < 33  ? 1 3 ) y SWH Y < 44  y 1 3 ) 

COMMON  TPSL ( 49  y 1 3 ) y VGT A < 1 5 y 1 3 ) 

C 

C EXPECTATION  VALUES 

r' 

L/ 

COMMON  ANIMAL(13y6) yCLIMAT(8y6) yGENDES(8y6) yGRWHYD(19y6) 
COMMON  0VRBDN(28y 6) yS0CECN(29y6) ySUBSOI (30y6) ySURHYD(23y6) 
COMMON  T0PS0I(33y6) y VEGETA ( 1 0 y 6 ) 

C 

C CATEGORY  RESPONSES 

C 

COMMON  RANIMA(3)  yRCHMA(2)  y RGENDE  ( 3 ) y RGRWHY  ( 5 ) 
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0101 
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C 

C 

C 


C 


C 


C 


C 

C 


C 


C 


c 


COMMON  R00RBD<7,10) tRS0CEC(6) >RS(JBS0(8) jRSURHY(6) 
COMMON  RT0PS0<9) yRVEGET (2) 

FEASIv TECONrOPUSE  SUBSYSTEM  PARAMETERS 

COMMON  CAAHM»CABAHjCABFN(3) >CABFP<3) jCABHM 

COMMON  CABS  < 2 ) y C AC  r C ACP  r CABF  y CABH 

COMMON  CABS  y CAEAF  y CAHSAF  y CAHSTS  y CAIP 

COMMON  CAR3FC  y CASF  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y F AVG  < 5 ) y PFSTSP  y PF AC  y RCLTEC ( 29  y 34 ) 

COMMON  TCAR<5) yTHICK(lO) y THKTSy  TTL(40) 


INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 


EXI T y CLMA  y GOES  y GUH Y y OOBD  y SBSL 
SCEC  y SWH Y y TPSL  y V6T A y AN I M 
CLIMAT  y 6ENBES y GRWHYB  y OORBDN 
SOCECN  y SUBSOI y SURH YD  y TOPSOI 
OEGETAy ANIMAL 

RCL 1 M A y RGENDE  y RGRUHY  y ROORBD  y RSOCEC 
RSUBSO y RSURH Y y RTOPSO y R0E6ET  y RANI MA 
RCLTECyTTL 


INTEGER  COMMON  <1) 

EQUIOALENCE  (COMMON  (l)y  ITEK  <D) 
EQUIOALENCE  (lARRY  (l)y  LUT) 
EQUIVALENCE  (IARY2  (l)y  ISTRK) 
EQUIVALENCE  (1ARY2  (2)y  ISECT) 
EQUIVALENCE  (IARY2  <3)y  ICODE) 
EQUIVALENCE  (1ARY2  <4)y  LEN) 


LOGICAL  LER 
INTEGER  ICHNG  (7) 

DATA  ICHNG  /2H  By2H  Cy2H  Dy2H  Ey2H  Fy2H  Gy2H  H/ 


10 


20 


WRITE 

GOTO 

WRITE 

READ 

IF 

IF 

WRITE 

GOTO 

WRITE 

READ 

IF 

IF 

WRITE 

GOTO 


30  WRITE 
WRITE 
READ 
IF 
IF 


ly  13) 


OUTPUT  HEADING 

(LUTylOOO)  (SBSL  (J)y  J = 1 y 13) 
(lOy 20y30y40y50y60y 70y80)  LEXIT 

USER  INPUT  ->  THICKNESS 
(LUTylOlO)  (TPSL  (2yJ)y  J = 
(LUTy)^)  RSUBSO  (1) 

(RSUBSO  (1)*EQ*0)  GOTO  500 
(RSUBSO  (1) ♦GE^1.AND*RSUBS0 
(LUTyl015)  RSUBSO  (1) 

10 

USER  INPUT  ->  TEXTURE 
( LUT y 1030)  ICHNG  (l)y  (TPSL 
(LUT?:^)  RSUBSO  (2) 

(RSUBSO  (2)*EQ<-0)  GOTO  500 
( RSUBSO  ( 2 ) 4 6E ♦ 1 ♦ AND ♦ RSUBSO 
(LUTyl015)  RSUBSO  (2) 

20 

USER  INPUT  ->  STRUCTURE 
(LUTyl040)  ICHNG  (2)y  (TPSL 
(LUTylOlO)  (TPSL  (20yJ)  y J 
(LUTy)Jc)  RSUBSO  (3) 

(RSUBSO  (3)4EQ»0)  goto  500 
(RSUBSO  (3) 46E4l 4AND<RSUBS0 


(1)  4LEMSUB 


(12yJ)y  J “• 


(1))  GOTO  20 


13) 


(2)4LEMSUB  (2))  GOTO  30 


(19y J) y 
= lyl3) 


J 


2y 


13) 


(3)4l-E4lSUB  (3))  GOTO  40 


37 


I 


0111 

0112 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120 
0121 
0122 

0123 
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0164 
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0166 


WRITE  (LUTyl015)  RSUBSO  (3) 

GOTO  30 

C USER  INPUT  ->  BULK  DENSITY 

40  WRITE  (LUT>i040)  ICHN6  (3)»  (TPSL  (24>J)»  J =:  2j13) 

WRITE  (LUTylOlO)  (TPSL  <25yJ),  J = 1»13) 

READ  (LUTyJJc)  RSUDSO  (4) 

IF  (RSUBSO  (4)*EQ«0)  GOTO  500 

IF  (RSUBSO  (4) .6E*1 ♦AND»RSUBSO  (4).LE.ISUB  (4))  GOTO  50 
WRITE  (LUTf  1015)  RSUBSO  (4) 

GOTO  40 

C USER  INPUT  ~>  SALINITY 

50  WRITE  (LUTyl030)  ICHNG  (4)»  (TPSL  (28fJ)r  J = 2yl3) 

READ  (LUTyJt:)  RSUBSO  (5) 

IF  (RSUBSO  (5)*EQ*0)  GOTO  500 

IF  (RSUBSO  (5) *GE»1*AND*RSUBS0  (5)*LE*ISUB  (5))  GOTO  60 
WRITE  (LUTyl015)  RSUBSO  (5) 

GOTO  50 

C USER  INPUT  ~>  SODIUM  ADSORPTION  RATIO 

60  WRITE  (LUTyl040)  ICHNG  (5)y  (TPSL  (34yJ)  y J = 2yl3) 

WRITE  (LUTylOlO)  (TPSL  (35yJ)y  J = lyl3) 

READ  (LUTyJfJ)  RSUBSO  (6) 

IF  (RSUBSO  (6)»ECnO)  GOTO  500 

IF  (RSUBSO  (6) .GE»1*AND. RSUBSO  (6),LE.ISUB  (6))  GOTO  70 
WIs'ITE  (LUfyl015)  RSUBSO  (6) 

GOTO  60 

C USER  INPUT  “>  AVAILABLE  NITROGEN 

70  WRITE  (LUTyl040)  ICHNG  (6)y  (TPSL  (40yJ)y  J = 2yl3) 

WRITE  (LUTylOlO)  (TPSL  (41yJ)y  J=lyl3) 

READ  (LUTy^i:)  RSUBSO  (7) 

IF  (RSUBSO  (7)«EQ.O)  GOTO  500 

IF  (RSUBSO  (7) ♦GE*1*AND*RSUBS0  (7)*LE*ISUB  (7))  GOTO  80 
WRITE  (LUTyiOlS)  RSUBSO  (7) 

GOTO  70 

C USER  INPUT  ->  AVAILABLE  PHOSPHORUS 

80  WRITE  (LUTyl040)  ICHNG  (7)y  (TPSL  (45yJ)y  J = 2yl3) 

WRITE  (LUTylOlO)  (TPSL  (46yJ)y  J = lyl3) 

READ  (LUTy){<)  RSUBSO  (8) 

IF  (RSUBSO  (8)»EQ»0)  GOTO  500 

IF  (RSUBSO  (8) *GE* 1 ♦ AND ♦RSUBSO  (8)*LE»ISUB  (8))  RETURN 
WRITE  (LUfylOlS)  RSUBSO  (8) 

GOTO  80 


C 

500 


C 

1000 
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1010 


C 

1015 

C 

1030 


C 


1040 

C 

C 


EXIT  = 
RETURN 

FORMAT 

FORMAT 

FORMAT 

FORMAT 

FORMAT 


USER  WANTS  OUT  ->  SET  EXIT  TO  ZERO  AND  RETURN 

0 

FORMAI  STATEMENTS 
(/5Xy 13A2) 

( SXylSAZ*  ->  _‘) 

(A2y“  ??  ->  RE~INPUT»M 

(/5X?A2pl2A2*  -->  „*') 

(/5Xy A2y 12A2) 
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SCATS  1=^00004  IS  ON  CR00015  USING  00030  BLKS  R=0000 

I 

! 

0001  FTN4 

0002  SUBROUTINE  CATS 

0003  C ABBREOIATED  DISPLAY — CATEGORY  S / OVERBURDEN 

0004  C 

0005  C LEVEL  2 

0006  C 

0007  C CATS  IS  ACCESSED  BY  EIAD  TO  SCHEDULE  INPUTS  TO  THE  CATEGORY 

0008  C RESPONSES  IN  CATEGORY  V - OVERBURDEN > USING  ABBREVIATED  DISPLAY 

0009  C 

0010  t;  THE  CALLING  SEQUENCE  IS  t CALL  CATS 

0011  C 


0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 


C 

C THIS  ROUTINE  WAS  WRITTEN  BY  EASTMAN  AND  MODIFIED  BY  GREEN 
C 

C CLAIM  RELEASE  1*0  - APRIL  If  1980 

C 

C TEKTRONIX  COMMON 

C 

COMMON  ITEK  (45) 

C 

C LOGICAL  UNITS  AND  COMMON  LOCATION 

C 

COMMON  IARRY<5) » I ARY2 ( 5 ) » LER » LUF y LUL 
C 

C POINTERS 

C 

COMMON  EXIT  y IANM<3) y ICLI (2) » IGEN<3) » IGRW<5) 

COMMON  lOPTN  y lOVR < 7 ) y IPNTR  y ISOC ( 6 ) y ISUB ( 8 ) 

COMMON  ISUR(6) y IT0P(9) y 1VE6(2) yLEXIJ  yLUO 
COMMON  MODE  yNANM  yNCLl  yNGEN  yNGRW 

COMMON  NOVR  yNSECTS  yNSOC  yNSUB  yNSUR 

COMMON  NTOP  yNU  yNVEG 

C 

C GRADING  PARAMETERS 

C 


0037 

0038 

0039 

0040  C 

0041  C 

0042  C 

0043 

0044 

0045 

0046  C 

0047  C 

0048  C 

0049 

0050 

0051 

0052  C 

0053  C 

0054  C 


COMMON  AREA ( 5 ) y BENLEN ( 5 y 1 0 ) y BENWI ( 5 y 1 0 ) y COGO  y GCPA ( 5 ) 
COMMON  GRDVBS ( 5 ) y HWHT  < 5 y 1 0 ) y HWSL 1 ( 5 y 1 0 ) y NSPP ( 5 ) y PCEQl 9 < 4 ) 
COMMON  PERCNT ( 5 y 10 ) y REHCPY < 5 ) y REHVOL < 5 ) y SLOPE ( 5 y 10 ) y WBP 


CATEGORY  TEXT 

COMMON  ANIM(23y 13) y CLMA < 13 y 1 3 ) y GDES ( 1 5 y 1 3 ) y GWHY ( 22 y 13 ) 
COMMON  0 VBD < 1 1 y 1 3 ) y BBSL ( 1 3 ) y SCEC ( 33  y 1 3 ) y SWH Y ( 44  y 1 3 ) 

COMMON  TPSL(49y 13) y VGTA( ISy 13) 

EXPECTATION  VALUES 

COMMON  AN I HAL ( 1 3 ? 6 ) y CL 1 MAT  < 8 y 6 ) y 6ENDES  < 8 y 6 ) y GRWH YD  < 1 9 y 6 ) 
COMMON  OVRBDN  < 28  y 6 ) y SOCECN ( 29  y 6 ) y SUBSOI < 30  y 6 ) y SURH YD ( 23  y 6 ) 
COMMON  TOPSOI < 33  y 6 ) ? VEGETA ( 1 0 ? 6 ) 

CATEGORY  RESPONSES 
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0055 

0056 

0057 

0058 

0059 

0060 
0061 
0062 
0063 
006A 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 


0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 
0101 
0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


c 

c 

c 


c 


c 

c 


c 


c 


COMHON  RAra'HA<3) ?RCLIMA(2) ?KGENUE<3) yRGRWHy<5) 
COMMON  R00RBD(7> 10) >RS0CEC(6) » RSUBSO ( 8 ) > RSURHY < 6 ) 
COMMON  RT0PS0(9) rR0E6ET<2) 

EEASI y 7 ECON  ? OPUSE  SUBS YSTEM  PARAMETERS 

COMMON  C AAHM  y C ABAH  y C ABFN ( 3 ) y CABFP  < 3 ) y CABHM 

COMMON  CABS ( 2 ) y C AC  y C ACP  y CADF  y CABH 

COMMON  CADS  ? CAEAF  y CAHSAF  y CAHSTS y CA I P 

COMMON  CAR3FC  y CASF  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y F A06 ( 5 ) y PFSTSP  y PF AC  y RCLTEC ( 29  y 34 ) 

COMMON  TCAR<5) y THICK < 10 ) y THKTS y T TL ( 40 ) 

INTEGER  EXIT  y CLMA  y GDESy  6UHY  y OOBD  y SBSL 
INTEGER  SCEC  y SUH Y y TPSL  y V6T A y AN I M 
INTEGER  CLlMATyGENDESyGRWHYDyOURBBN 
INTEGER  SOCECN  y SUBSOI y SURHYD  y TOPSOI 
INTEGER  OEGETAy ANIMAL 

I NTE6ER  RCL I MA  y RGENDE  y RGRWHY  y ROORBD  y RSOCEC 
INTEGER  RSUBSO  y RSURHY  y RTOPSO  y RVEGET  y RANIMA 
INTEGER  RCLTEC yTTL 

INTEGER  COMMON  (1) 


007B 

EQUIVALENCE 

(COMMON 

d) 

y ITEK 

0079 

EQUIVALENCE 

(lARRY 

(1)  y 

LUT) 

0080 

EQUIVALENCE 

(IARY2 

(1)  y 

ISTRK) 

0081 

EQUIVALENCE- 

(IARY2 

(2)  y 

ISECT) 

0082 

EQUIVALENCE 

(IARY2 

(3)  y 

ICODE) 

0083 

EQUIVALENCE 

(IARY2 

(4)  y 

LEN) 

0004  C 
0085 

LOGICAL  LER 

0086 

INTEGER  ICHN6  (5) 

0087  C 

• 

0088 

DATA  ICHNG/2H  Dy2H 

Ef2H 

Fy2H  6 

0089 

IF  (IPNTR 

. NE ♦ 2 ) 

NU 

= 1 

5 


10 


15 


WRITE 

GOTO 

IF 

WRITE- 

WRITE 

READ( 

IF 

IF 

WRITE 

GOTO 

WRITE 

READ( 

IF 

WRITE 

GOTO 


13) 


ly 13) y I = 2y3) 


0U7PUT  HEADING 

(LUTyiOOO)  (OMBDdyJ)  y J = ly 
<5y 15y20y30y40y50y60y70)  LEXIT 

USER  INPUT  ->  NUMBER  OF  ROCKS 
<NU*EQ*0)  NU  = 1 
(LUTyl041)  NU 
<LU7yl020)  ((OMBD(IyJ)y  J 
LUTy:^)  ROORBD(lyNU) 

(ROURBD(lyNU) <EQ<0)  GOTO  500 
(ROURBDd  yNU)  * BE  d ^ AND  . ROURBD  d y NU ) *LE 
(LUTyiOlG)  ROURBDdyNU) 

10 

USER  INPUT  -~>  THICKNESS  OF  UNIT 
<LUT? 1042) 

LUTy)(0  THICK  (NU) 

(THICK  (NU).GE<-5<)  GOTO  20 


lOURd)  ) 


GOTO  15 


(LUTylOlS)  THICK  (NU) 


15 


20  WF:ITE 


USER  INPUT  ->  TEXTURE 
(LUTylOSO)  ((OUBD(IyJ)y  J = lyl3)y  I 


8y  10) 
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0111 

0112 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120 

0121 

0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 

0161 

0162 

0163 

0164 

0165 

0166 


REALKLUTy  ROORDD  ( 2 y NU ) 

IF(R00RBD<2>NU) ^EQvO)  GOTO  500 

IF  <RG0RBD<2jNU) *6E* 1 ♦AND*R00RBD(2yNU) *LE* I00R(2) ) GOTO  30 
WRITE  (LUTflOlS)  ROORBD ( 2 > NO ) 

GOTO  20 

C USER  INPUT  ->  BULK  DENSITY 

30  WRITE  (LUT,1040)  ICHNG  (l)y  <TPSL  <24?J)»  J = 2>13) 

WRITE  (LUTjIOIO)  <TPSL  (20»J)t  J = 1>13) 

READ(LUT,3«:)  R00RBD(3?NU) 

IF  (R00RBD(3jNU) *£0.0)  GOTO  500 

IF  <R0URBD<3jNU) ♦GE*1*AND.R0VRBD(3»NU) ♦LE*I00R(3) ) GOTO  40 
WRITE  (LUTjIOIS)  R0VRBD<3jNU) 

GOTO  30 

C USER  INPUT  ~>  SALINITY 

40  WRITE  (LUT»1030)  ICHNG  (2)>  (TPSL  (28»J)>  J = 2»13) 

READ(LUTjJJc)  R0MRBD(4yNU) 

IF  (R00RBD(4f NU) *EQ*0)  GOTO  500 

IF  <R00RBD(4yNU)*GE»l*AND*R00RBD<4yNU)<LE*I00R(4)>  GOTO  50 
WRITE  (LUTjIOIS)  R0VRBD(4?NU) 

GOTO  40 

C USER  INPUT  ->  SODIUM  ADSORPTION  RATIO 

50  WRITE  <LUTyl040)  ICHNG  (3)»  (TPSL  (3^yJ)y  J = 2yl3) 

WRITE  CLUTylOlO)  (TPSL  (35yJ)y  J = lyl3) 

READ ( LUT  y t ) ROORBD ( 5 y NU ) 

IF  (R00RBD(5yNU) tEQ^O)  GOTO  500 

IF  (R00RBD(5yNU) ♦GE.l ♦AND»R00RBD(5yNU) ♦LE^I0VR(5) ) GOTO  60 
WRITE  (LUTyl015>  R00RBD(5yNU) 

GOTO  50 

C USER  INPUT  ->  AVAILABLE  NITROGEN 

60  WRITE  (LUTyl040)  ICHNG  (4)  y (TPSL  (40yJ)y  J = 2yl3) 

WRITE  (LUTylOlO)  (TPSL  (41yJ)y  J = lyl3) 

READ ( LUT  y t ) ROVRBD ( 6 y NU ) 

IF  (R0VRBD(6yNU) ♦ECUO)  GOTO  500 

IF  (R0VRBD(6yNU) ♦GE. 1 ♦ AND*R0URBD(6yNU)  a_E.10VR(6) ) GOTO  70 
WRITE  (LUTyl015)  R0VRBD(6yNU) 

GOTO  60 

C USER  INPUT  “>  AVAILABLE  PHOSPHORUS 

70  WRITE  (LUTyl040)  ICHNG  (5)y  (TPSL  (45yJ)y  J = 2y  13) 

WRITE  (LUTrlOlO)  (TPSL  (46yJ)y  J = lyl3) 

READ ( LUT  y t ) RGVRBD ( 7 y NU ) 

IF  (R0VRBD(7yNU) ♦EQ<0)  GOTO  500 

IF  (R0VRBD(7yNU)*GEtl*AND«R0VRBD(7yNU)»LE*I0VR(7))  GOTO  100 
WRITE  (LUTyl015)  R0VRBD(7y  NU) 

GOTO  70 

C USER  SELECTION  ->  ANOTHER  UNIT  ? 

100  IF  (NU«.E0*10)  RETURN 
WRITE  (LUTyl051) 

READ ( LUT y 1011 ) IANS 

IF  (IANS*NE<.2HYE)  RETURN 
NU  NU  -F  1 

IF  (LER)  CALL  ERASE 
IF  (LER)  CALL  HOME 
GOTO  5 

C USER  WANTS  OUT  ->  SET  EXIT  TO  ZERO  AND  RETURN 

500  EXIT  = 0 
RETURN 


0167 

C 

FORMAT  STATEMENTS 

0168 

1000 

FORMAT 

</5Xy 13A2) 

' 

0169 

C 

0170 

1010 

FORMAT 

( 5Xj13A2"  -> 

0171 

C 

0172 

1011 

FORMAT 

<A2) 

0173 

C 

0174 

1015 

FORMAT 

(A2*'  ??  “>  RE-INPUT 

♦ ■ ) 

0175 

C 

0176 

1020 

FORMAT 

</5X>13A2/5X>13A2" 

->  _■) 

0177 

C 

0178 

1030 

FORMAT 

</5X?A2>12A2-  -> 

) 

0179 

C 

0180 

1040 

FORMAT 

(/5X»A2f 12A2) 

0181 

C 

0182 

1041 

FORMAT 

</5X'N0W  WORKING  ON 

LITHOLOGIC  UNIT 

•12) 

0183 

C 

0184 

1042 

FORMAT 

(/5X*  B<)  THICKNESS 

OF  THIS  UNIT->  . 

-■  ) 

0185 

C 

0186 

C 

0187 

1050 

FORMAT 

(2  </5X»13A2  )j/5X> 

13A2"  -> 

0188 

C 

0189 

1051 

FORMA? 

</5X* PROCEED  TO  THE 

NEXT  LITHOLOGIC 

UNIT 

0190 

C 

0191 

END 

0192 

END$ 
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&CAT6 
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0010 

0011 

0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 

0021 

0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 
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0054 
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SUBROUTINE  CAT6 

C ABBREVIATED  DISPLAY — CATEGORY  6 / SURFACE  OjATER  HYDROLOGY 

C 

C LEVEL  2 
C 

C CAT6  IS  ACCESSED  BY  EIAD  TO  SCHEDULE  INPUTS  TO  THE  CATEGORY 
C RESPONSES  IN  CATEGORY  VI  - SURFACE  WATER  HYDROLOGY > USING 
C ABBREVIATED  DISPLAY 
C 

C THE  CALLING  SEQUENCE  IS  : CALL  CAT6 

C 

C 

C THIS  ROUTINE  WAS  WRITTEN  BY  EASTMAN  AND  MODIFIED  BY  GREEN 
C 

C CLAIM  RELEASE  1«0  - APRIL  1>  1980 

c 

C TEKTRONIX  COMMON 

C 

COMMON  ITEK  <45) 

C 

C LOGICAL  UNITS  AND  COMMON  LOCATION 

C 

COMMON  I ARR Y < 5 ) » I ARY2  < 5 ) > LER  ? LUF » LUL 
C 

C POINTERS 

C 

COMMON  EXIT  » IANM<3) > ICLI (2) » IGEN(3) > IGRW<5) 

COMMON  lOPTN  , IOVR< 7 ) > IPNTR  > IS0C(6) » ISUB(8) 

COMMON  ISUR<6) »IT0P(9) jIVEG(2) »LEXIT  tLUO 
COMMON  MODE  >NANM  jNCLI  »NGEN  >NGRW 

COMMON  NOVR  rNSECTS  »NSOC  »NSUB  fNSUR 

COMMON  NTOP  fNU  >NVEG 

C 

C GRADING  PARAMETERS 

C 

COMMON  AREA(5) fBENLEN<5»10) tBENWKSj 10) yC0G0»GCPA<5) 
COMMON  GRDVBS  < 5 ) j HWHT  < 5 r 1 0 ) > HWSL I ( 5 » 1 0 ) > NSPP  < 5 ) > PCEQl 9 < 4 ) 
COMMON  PERCNT ( 5 » 1 0 ) » REHCP Y ( 5 ) » REHVOL ( 5 ) » SLOPE ( 5 t 1 0 ) > WBP 
C 

C CATEGORY  TEXT 

C 

COMMON  ANIM<23>13) fCLMA(13>13) »GDES(15»13) »GWHY(22j13) 
COMMON  0VBD<11j13)>SBSL(13)»  SCEC<33» 13) j SWHY<44» 13) 
COMMON  TPSL<49rl3) »VGTA<15»13) 

C 


C EXPECTATION  VALUES 

C 

COMMON  ANIMAL<13>6) >CLIMAT<8>6) »GENDES(8»6) yGRWHYD(19y6) 
COMMON  0VRBDN(28t6) >S0CECN(29t6) jSUBSOI (30j6) >SURHYD(23t6) 
COMMON  T0PS01(33t6) fVE6ETA(10r6) 

C 

C CATEGORY  RESPONSES 
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0056 

0057 

0058 

0059  C 

0060  C 

0061  C 

0062 

0063 

0064 

0065 

0066 

0067 

0068  C 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077  C 

0078 

0079 

0080 
0081 
0082 

0083 

0084 

0085  C 

0086 

0087  C 

0088  C 

0089 

0090 

0091  C 

0092 

0093 

0094 

0095 

0096 

0097 

0098  C 

0099 

0100 
0101 
0102 

0103 

0104 

0105  C 

0106 

0107 

0108 

0109 

0110 


COMMON  RANIMA<3) fRCLlMA(2) tR6ENIiE<3>  jRGRWHY<5) 
COMMON  ROORBD ( 7 y 1 0 ) t RSOCEC ( 6 ) j RSUBSO  < 8 ) y RSURH Y ( 6 ) 
COMMON  RT0PS0<9) jRME6ET<2) 

FEASIfTECONrOPUSE  SUBSYSTEM  PARAMETERS 

COMMON  CAAHM  j CABAH  ? CABFN  < 3 ) » CABFP ( 3 ) f CABHM 

COMMON  C ABS ( 2 ) y CAC  y CACP  y CADF  y CADH 

COMMON  CABS  y CAEAF  y CAHSAF  y CAHSTS  y CAIP 

COMMON  CAR3FC  y CASF  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y FA06  < 5 ) y PFSTSP  y PFAC  y RCLTEC ( 29  y 34 ) 

COMMON  TCAR  < 5 ) y THI CK ( 1 0 ) y THKTS  y TTL ( 40 ) 


1 NTEGER  EXI T y CLMA  y GDES  y GUH Y y OMBD  y SBSL 
INTEGER  SCEC  y SUH Y y TPSL  y V6T A y AN I M 
INTEGER  CLIMATyGENBESyGRWHYByOVRBDN 
INTEGER  SOCECNySUBSOIySURHYBy  TOPSOI 
INTEGER  OEGETAyANIMAL 

IN  f EGER  RCL IMA  y RGENDE  y R6RWHY  y ROORBD  y RSOCEC 
I NT  EGER  RSUBSO  y RSURHY  y RTOPSO  y R0E6E  f y RANIMA 
INTEGER  RCLTECyTTL 


INTEGER  COMMON  <1) 

EQUIVALENCE  (COMMON  <l)y  ITEK 


EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 


(lARRY 

(IARY2 

(IARY2 

(IARY2 

(IARY2 


(1)  y 
<l)y 
<2)y 

(3)  y 

(4)  y 


LUT  ) 
ISTRK) 
ISECT) 
I CODE) 
LEN) 


1)  ) 


LOGICAL  LER 

OUTPUT  HEADING 

WRITE  (LUTyl005)  ( (SWHY  (lyJ)y  J = lyl3)y  I = ly2) 

GOTO  <lCy20y30y40y50y60)  LEXIT 

USER  INPUT  ->  TYPE  OF  SURFACE  WATER  PRESENT 
10  WRITE  (LUTylOSO)  ((SWHY  (lyJ)y  J = lyl3)y  I = 3y5) 

READ  (LUTyi^:)  RSURHY  (1) 

IF  (RSURHY  (1)*EQ*0)  GOTO  500 

IF  (RSURHY  (1) ♦GE*1*AND*RSURHY  (1)>LE*ISUR  (1))  GOTO  20 
WRITE  (LUTylOlS)  RSURHY  (1) 

GOTO  10 

USER  INPUT  ->  AMOUNT  OF  WATER  PRESNT 
20  WRITE  (LUTyl060)  ((SWHY  (lyJ)y  J = lyl3)y  I = llyl9) 

READ  (LUTy^tO  RSURHY  (2) 

IF  (RSURHY  (2)*EQ>0)  GOTO  500 

IF  (RSURHY  (2)*GE*1*AND*RSURHY  (2)*LE*ISUR  (2))  GOTO  30 
WRITE  (LUT y 1015)  RSURHY  (2) 

GOTO  20 

USER  INPUT  ->  INDEX  OF  DISSECTION 
30  WRITE  (LUTylOlO)  (SWHY  (25yJ)y  J = lyl3) 

READ  (LUfy)fO  RSURHY  (3) 

IF  (RSURHY  (3)*EQ«0)  GOTO  500 

IF  (RSURHY  (3) *GE.l. AND. RSURHY  (3).LE.ISUR  (3))  GOTO  40 
WRITE  (LUTylOlS)  RSURHY  (3) 
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GOTO  30  ' 


0111 

0112 

C 

0113 

40 

0114 

0115 

0116 

0117 

0118 
0119 

C 

0120 

50 

0121 

0122 

0123 

0124 

0125 

0126 

C 

0127 

60 

0128 

0129 

0130 

0131 

0132 

0133 

C 

0134 

500 

0135 

0136 

C 

0137 

1005 

0138 

C 

0139 

1010 

0140 

C 

0141 

1015 

0142 

C 

0143 

1020 

0144 

C 

0145 

1050 

0146 

C 

0147 

1060 

0148 

C 

0149 

0150 

END$ 

USER  INPUT  ->  INDEX  OF  MEANDER 
WRITE  (LUTylOlO)  (SWHY  <29tJ)j  J = 13) 

READ  <LUT>)»:)  RSURHY  (A) 

IF  (RSURHY  (4)*EQ*0)  GOTO  500 

IF  (RSURHY  (4) *GE*1*AND*RSURHY  (4)*LEtlSUR  (4))  GOTO  50 
WRITE  (LUTrlOlS)  RSURHY  (4) 

GOTO  40 

USER  INPUT  ->  SALINITY 

WRITE  (LUTf1020)  ((SWHY  (l»J)f  J = 1>13)»  I = 33»34) 

READ  (LUT»)IO  RSURHY (5) 

IF  (RSURHY  (5)*EQ*0)  GOTO  500 

IF  (RSURHY  (5)*GE»1*AND. RSURHY  (5)*LE.ISUR  (5))  GOTO  60 
WRITE  (LUT»1015)  RSURHY  (5) 

GOTO  50 

USER  INPUT  ~>  SODIUM  ADSORPTION  RATIO 
WRITE  (LU7»1020)  ((SWHY  (IfJ)y  J = 1t13)>  I = 39>40) 

READ  (LUTfH^)  RSURHY  (6) 

IF  (RSURHY  (6)«EQ*0)  GOTO  500 

IF  (RSURHY  (6) ♦6E*1 *AND^RSURHY  (6)*LE*ISUR  (6))  RETURN 
WRITE  (LUTflOlS)  RSURHY  (6) 

GOTO  60 

USER  WANTS  OUT  ->  SET  EXIT  TO  ZERO  AND  RETURN 

EXIT  = 0 
RETURN 

FORMAT  STATEMENTS 
FORMAT  (2(/5X»13A2) ) 

FORMAT  (/5X»13A2‘  -> 

FORMAT  (A2*  ??  ->  RE-INPUT*") 

FORMAT  (/5X>13A2  »/5X>13A2‘  ->  __") 

FORMAT  (2(/5Xj13A2)  y/5Xfl3A2"  ->  _") 

FORMAT  (8(/5X>13A2)  y/5Xrl3A2"  ->  _") 

END 
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0020 

0021 

0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 
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0039 

0040 
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0044 
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SUBROUTINE.  CAT7 

C ABBREVIATED  DISPLAY — CATEGORY  7 / GROUND  WATER  HYDROLOGY 

C 

C LEVEL  2 
C 

C CAT?  IS  ACCESSED  BY  EIAD  TO  SCHEDULE  INPUTS  TO  THE  CATEGORY 
C RESPONSES  IN  CATEGORY  VII  - GROUND  WATER  HYDROLOGY f USING 
C ABBREVIATED  DISPLAY 
C 

C THE  CALLING  SEQUENCE  IS  J CALL  CAT? 

C 

C 

C THIS  ROUTINE  WAS  WRITTEN  BY  EASTMAN  AND  MODIFIED  BY  GREEN 
C 

C CLAIM  RELEASE  1*0  - APRIL  1j  1980 

c 

C TEKTRONIX  COMMON 

C 

COMMON  ITEK  <45) 

C 

C LOGICAL  UNITS  AND  COMMON  LOCATION 

C 

COMMON  IARRY(5) > IARY2<5) f LER»LUF»LUL 
C 

C POINTERS 

C 

COMMON  EXIT  , 1 ANM ( 3 ) ? ICLI ( 2 ) f IGEN ( 3 ) » IGRW ( 5 ) 

COMMON  lOPTN  ? lOVR ( 7 ) » IPNTR  j IS0CC6) y ISUB(8) 

COMMON  ISUR(6) j 1T0P(9) » 1VEG(2) » LEXIT  tLUO 
COMMON  MODE  >NANM  »NCLI  tNGEN  »NGRW 

COMMON  NOVR  jNSECTS  jNSOC  jNSUB  >NSUR 

COMMON  NTOP  >NU  »NVEG 

C 

C GRADING  PARAMETERS 

C 

COMMON  AREA  < 5 ) > BENLEN  < 5 » 1 0 ) j BENWI < 5 > 1 0 ) y COGO » GCPA ( 5 ) 

COMMON  GRDVBS<5) rHWHf (5? 10) fHWSLKSf 10) >NSPP(5) »PCEQ19(4) 
COMMON  PERCNT<5»10) ,REHCPY<5) >REHV0L(5) >SL0PE(5j10) jWBP 
C 

C CATEGORY  TEXT 

C 

COMMON  ANIM(23j13) >CLMA( 13 j 13) »GDES< 15^13 ) >GWHY (22^13) 
COMMON  0VBD<llfl3)»SBSL(13) j SCEC ( 33 > 13 ) » SWHY < 44 y 13 ) 

COMMON  TPSL(49y 13) yVGTA(15yl3) 

C 

C EXPECTATION  VALUES 

C 

COMMON  ANIMAL(13y6) yCLlMAT(8y6) yGENDES(8y6) yGRWHYD(19y6) 
COMMON  0VRBDN(28y6) yS0CECN(29y6) ySUBS0K30y6) ySURHYD(23y6) 
COMMON  T0PS0K33y6)  y VEGETA(10y6) 

C 

C CATEGORY  RESPONSES 
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0055 

0056 

0057 

0058 

0059 

0060 
0061 
0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 


0085 

0086 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 
0101 
0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


C 

C 

C 


C 

C 


COMMON  RANIMA<3) »RCLIMA(2) tRGENDE(3) rR0RWHY<5) 
COMMON  ROORED ( 7 y 1 0 ) t RSOCEC  < 6 ) » RSUESO  < 8 ) > RSURH Y ( 6 ) 
COMMON  RT0PS0(9) jROEGET (2) 

FEASIf TECONfOPUSE  SUBSYSTEM  PARAMETERS 


COMMON 

COMMON 

COMMON 

COMMON 

COMMON 

COMMON 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 


CAAHM  f CABAN  f CABFN ( 3 > t CABFP ( 3 ) f CABHM 

CABS ( 2 ) F CAC  F CACP  f CABF  f CADH 

CADS  F CAEAF  f CAHSAF  f CAHSTS  f CA I P 

CAR3FC  F CASF  f CASNC  f CSTES  f CSTRM 

CSTRP  F F AUG ( 5 ) F PFSTSP  f PFAC  f RCLTEC  < 29  f 34 ) 

TCAR(5) fTHICK(IO) fTHKTSfTTL<40) 

EXI T F CLMA  F GDES  F GWHY  f OUBD  f SBSL 
SCEC  F SWHY  F TPSL  f OGT A f ANIM 
CLIMAT  F GENDES  f GRWHYD  f OORBDN 
SOCECN  F SUBSOI f SURHYD f TOPSOI 
OEGETAfANIMAL 

RCL I MA  F RGENDE  f RGRWHY  f ROORBD  f RSOCEC 
RSUBSO  F RSURHY  f RTOPSO  f ROEGE  f f RANI MA 
RCLTECfTTL 


INTEGER  COMMON  <1) 


0079 

EQUIVALENCE 

(COMMON 

(1) 

F ITEK  (D) 

0080 

EQUIVALENCE 

(lARRY 

(1)f 

LUT) 

0081 

EQUIVALENCE 

(IARY2 

(1)  F 

ISTRK) 

0082 

EQUIVALENCE 

(IARY2 

(2)  F 

ISECT) 

0083 

EQUIVALENCE 

(IARY2 

(3)  F 

ICODE) 

0084 

EQUIVALENCE 

(IARY2 

(4)  F 

LEN) 

LOGICAL  LER 
INTEGER  ICHNG  (2) 

BATA  ICHNG  /2H  Cf2H  D/ 


WRITE 

GOTO 

10  WRITE 
READ 
IF 
IF 
WRITE 
GOTO 

20  WRITE 
READ 
IF 
IF 
WRITE 
GOTO 

30  WRITE 
WRITE 


OUTPUT  HEADING 

(LUTf1050)  ((GWHY  (IfJ)f  J = 1f13)f  1 = 1f2) 
(10f20f30f40f50)  LEXIT 

USER  INPUT  ~>  DEPTH  TO  WATER  TABLE 
(LUTf1060)  ((  GWHY  (IfJ)f  J = 1f13)f  I = 3f5) 

(LUfFifO  RGRWHY  (1) 

(RGRWHY  (1)*EQ*0)  GOTO  500 

(RGRWHY  (1) ♦GE*!* AND ♦RGRWHY  (1)*LE*1GRW  (1))  GOTO  20 
(LUTfIOIS)  RGRWHY  (1) 

10 

USER  INPUT  ->  AMOUNT  OF  GROUNDWATER 
(LUTf1070)  ((  GWHY  (IfJ)f  J = 1f13)f  I = 10f18) 
(LUTf*)  RGRWHY  (2) 

(RGRWHY  (2)*EQ<0)  GOTO  500 

(RGRWHY  (2) .GE.l.AND^RGRWHY  (2)*LE*IGRW  (2))  GOTO  30 
(LUTfIOIS)  RGRWHY  (2) 


20 


USER  INPUT  ->  SALINITY 

(LUTf1040)  ICHNG  (1)f  (SWHY  (33fJ)f  J = 3f13) 
(LUTfIOII)  ( SWHY  (34fJ)f  J = 1f13) 
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0111 

0112 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120 

0121 

0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 


READ  iLUJft)  R6RWHY  (3) 

IF  (R6RWHY  (3)*EQ*0)  GOTO  500 

IF  (RGRWHY  <3)*6E*1.AND.R6RWHY  <3)*LE.IGRW  (3))  GOTO  40 
WRITE  <LUT»1015)  RGRWHY  <3> 

GOTO  30 

C USER  INPUT  ~>  SODIUM  ADSORPTION  RATIO 

40  WRITE  (LUT»1040)  ICHNG  (2)f  (SWHY  <39>J)»J  = 3»13) 

WRITE  (LUTflOll)  (SWHY  (40»J)»  J = lrl3) 

READ  (LUTy*)  RGRWHY  (4) 

IF  (RGRWHY  (4)*EQ.O)  GOTO  500 

IF  (RGRWHY  (4)*GE*1*AND*RGRWHY  (4)»LE»IGRW  (4))  GOTO  50 
WRITE  (LUT»1015)  RGRWHY  (4) 

GOTO  40 

C USER  INPUT  ->  ALLUVIAL  VALLEY  FLOOR 

50  WRITE  (LUTfl020)  ((  GWHY  (I»J)>  J = lfl3)»  I = 19r20) 

READ  (LUTyJtc)  RGRWHY  (5) 

IF  (RGRWHY  (5)*EQ.O)  GOTO  500 

IF  (RGRWHY  ( 5 ).6E*1* AND* RGRWHY  (5)*LE*IGRW  (5))  RETURN 
WRITE  (LUTjIOIS)  RGRWHY  (5) 

GOTO  50 

C USER  WANTS  OUT  ->  SET  EXIT  TO  ZERO  AND  RETURN 


500 

EXIT  = 

0 

RETURN 

FORMAT  STATEMENTS 

1010 

FORMAT 

( 5Xfl3A2*  ->  -.•) 

1011 

FORMAT 

( 5X»13A2"  -> 

1015 

FORMAT 

(AZ*  ??  ~>  RE-INPUT**) 

1020 

FORMAT 

(/5Xj13A2  f/5X?13A2"  -> 

) 

1040 

FORMAT 

(/5X»A2^11A2) 

1070 

FORMAT 

( 8 ( /5X » 1 3 A2 ) f /5X  j 1 3 A2  * 

->  ^*) 

1060 

FORMAT 

( 2 ( /5X  ? 1 3A2 ) » /5X  t 1 3 A2  * 

->-.*) 

1050 

FORMAT 

(2(/5Xfl3A2  )) 

C 

END 


END$ 
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SCATS  T=00004  IS  ON  CR00015  USING  00019  BLKS  R=0000 

0001  FTN4 

0002  SUBROUTINE  CAI8 

0003  C ABBREVIATED  DISPLAY— CATEGORY  9 / VEGETATION 

0004  C 

0005  C LEVEL  2 

0006  C 

0007  C CATS  IS  ACCESSED  BY  EIAD  TO  SCHEDULE  INPUTS  TO  THE  CATEGORY 

OOOS  C RESPONSES  IN  CATEGORY  VIII  ~ VEGETATION?  USING  ABBREVIATED  DISPLAY 

0009  C 

0010  C THE  CALLING  SEQUENCE  IS  J CALL  CATS 

0011  C 

0012  C 

0013  C THIS  ROUTINE  WAS  WRITTEN  BY  EASTMAN  AND  MODIKIED  BY  GREEN 

0014  C 

0015  C CLAIM  RELEASE  1«0  - APRIL  1?  1980 

0016  C 

0017  C 

0018  C 

0019  C 

0020 

0021  C 

0022  C 

0023  C 

0024 

0025  C 

0026  C 

0027  C 

0028 

0029 

0030 

0031 

0032 

0033 

0034  C 

0035  C 

0036  C 

0037 

0038 

0039 

0040  C 

0041  C 

0042  C 

0043 

0044 

0045 

0046  C 

0047  C 

0048  C 

0049 

0050 

0051 

0052  C 

0053  C 

0054  C 


TEKTRONIX  COMMON 
COMMON  ITEK  <45) 

LOGICAL  UNITS  AND  COMMON  LOCATION 
COMMON  1ARRY<5) ?IARY2(5) »LER?LUF?LUL 
POINTERS 

COMMON  EXIT  ? IANM(3) ? ICLl <2) ? I6EN(3) ? IGRW(5> 

COMMON  lOPTN  ? lOVR ( 7 ) ? IPNTR  ? ISOC ( 6 ) ? ISUB ( 8 ) 

COMMON  ISUR<6) ? 1T0P<9) ? 1VEG(2>  ?LEXIT  »LUO 
COMMON  MODE  ?NANM  ?NCL1  ?NGEN  ?NGRW 

COMMON  NOVR  ?NSECTS  ?NSOC  ?NSUB  ?NSUR 

COMMON  NT  OP  >NU  ?NVEG 

GRADING  PARAMETERS 

COMMON  AREA  < 5 ) ? BENLEN  < 5 ? 1 0 ) ? BENW I ( 5 ? 1 0 ) ? COGO  ? GCPA  < 5 ) 

COMMON  GRD VBS ( 5 ) ? HWH T < 5 ? 1 0 ) ? HWSL 1 ( 5 ? 1 0 ) ? NSPP ( 5 ) ? PCEQl 9 < 4 ) 
COMMON  PERCNT  < 5 ? 1 0 ) ? REHCPY ( 5 ) ? REHVOL ( 5 ) ? SLOPE  < 5 ? 1 0 ) ? WBP 

CATEGORY  TEXT 

COMMON  ANIM<23? 13) ?CLMA<13?13) ?6DES<15? 13) ?GWHY(22? 13) 
COMMON  0VBD(ll?13)?SBSL<13)j  SCEC<33> 13) ?SWHY<44? 13) 

COMMON  TPSL(49?13) ?VGTA<15?13) 

EXPECTATION  VALUES 

COMMON  ANIMAL(13?6) ?CL1MAT(8?6) ?GENDES<8?6) ?GRWHYD(19?6) 
COMMON  UVRBDN  < 28  ? 6 ) ? SOCECN ( 29  ? 6 ) ? SUBSO I < 30  r 6 ) ? SURH  YD ( 23  ? 6 ) 
COMMON  T0PS0I(33?6) ?VEGETA<10?6) 

CATEGORY  RESPONSES 
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0055 

0056 
I 0057 
I 0058 

0059 

0060 
0061 
0062 
0063 

i 0064 
' 0065 

! 0066 
I 0067 
0068 
0069 
! 0070 

' 0071 

0072 

0073 

0074 
! 0075 

' 0076 

: 0077 

I 0078 

0079 

0080 
0081 
0082 

' 0083 

' 0084 

0085 
' 0086 
! 0087 

I 0088 

I 0089 
I 0090 
I 0091 
1 0092 

, 0093 

' 0094 

0095 

0096 
I 0097 

0098 
! 0099 

0100 
0101 
0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


C 

C 

C 


C 


C 


C 

C 

C 

C 


C 


C 


COMMON  RAN I MA  < 3 ) > RCL I MA  < 2 ) > RGENDE ( 3 ) ^ RGRWHY  < 5 ) 
COMMON  R0VRBD<7t10) »RS0CEC(6) jRSUBS0<8) »RSURHY(6) 
COMMON  RT0PS0(9) yROEGET <2) 

FEASI>TECON»OPUSE  SUBSYSTEM  PARAMETERS 


COMMON  CA AHM  t C ABAH  y C ABFN ( 3 ) > C ABFP  < 3 ) > C ABHM 

COMMON  C ABS  < 2 ) y C AC  y C ACP  t C ABF  > C ADH 

COMMON  CABS  t CAEAF  ? CAHSAF  » CAHSTS  ^ CAIP 

COMMON  CAR3FC  > CASF  » CASNC  ^ CSTES » CSTRM 

COMMON  CSTRP  > FAOG ( 5 ) y PFSTSP » PFAC  > RCLTEC ( 29  > 34 ) 

COMMON  TCAR<5) jTHICK(IO) >THKTSjTTL(40) 


INTEGER  EXI T > CLMA » GDES ? GWH Y ? OVBD f SBSL 
INTEGER  SCEC>SWHYjTPSL»06TAj ANIM 
INI  EGER  CL IMAT  ? GENBES  f GRWHYB  ? OVRBBN 
INTEGER  SOCECNySUBSOI»SURHYB»TOPSOI 
INTEGER  VEGETA f ANIMAL 

INTEGER  RCLI MA  y RGENBE  y R6RWHY  y ROVRBB y RSOCEC 
INTEGER  RSUBSO  y RSURHY  y RTOPSO  y RVEGET  y RANI MA 
INTEGER  RCLTECyTTL 


INTEGER  COMMON  <1) 

EQUIVALENCE  (COMMON  (l)y  ITEK  (D) 


EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 


(lARRY 

(IARY2 

(IARY2 

(IARY2 

(IARY2 


(1)  y 
(1)  y 
(2>y 

(3)  y 

(4)  y 


LUT) 
ISTRK) 
ISECT) 
I CODE) 
LEN) 


LOGICAL  LER 


OUTPUT  HEADING 

WRITE  (LUIylOOO)  (VGTA  <lyJ)y  J = lyl3) 

GOTO  (10y20)  LEXIT 

USER  INPUT  ~>  MOST  IMPORTANT  COMMUNITY  TYPE 
10  WRITE  <LUTyl020)  <<VGTA  <IyJ)y  J = lyl3)y  I = 2y3) 

READ  iLUJrt)  RVE6ET  (1) 

IF  (RVEGET  (l)*EQ.O)  GOTO  500 

IF  (RVEGET  (1) .6E*1.ANB«RVE6ET  (1)*LE*IVEG  (1))  GOTO  20 
WRITE  (LUTylOlS)  RVEGET  (1) 

GOTO  10 

USER  INPUT  ~>  SECONDARY  IMPORTANT  TYPES 
20  WRITE  (LUfylOlO)  (VGTA  (14yJ)y  J = lyl3) 

READ  (LUTy*)  RVEGET  (2) 

IF  (RVEGET  (2)*EQ»0)  GOTO  500 

IF  (RVEGET  (2) ♦6E,1*AND*RVEGET  (2)tLEiIVE6  (2))  RETURN 
WRITE  (LUTyl015)  RVEGET  (2) 

GOTO  20 

USER  WANTS  OUI  ->  SET  EXIT  TO  ZERO  AND  RETURN 

500  EXIT  = 0 
RETURN 


C FORMAT  STATEMENTS 

1000  FORMAT  (/5Xyl3A2) 

C 

1010  FORMAT  (/5Xyl3A2*  ->  _*) 
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I 


0111 

0112 

0113 

‘0114 

0115 

0116 
0117 


C 

1015  FORMAT  (A2"  ??  ~>  RE-INPUT** 
C 

1020  FORMAT  </5X>13A2»  /5X>13A2“ 

C 

END 

END$ 
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&CAT9  T=00004  IS  ON  CR0001t5  USING  00020  BLKS  R=0000 


0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 

0053 

0054 


FTN4 

SUBROUTINE  CAT9 

C ABBREVIATED  DISPLAY-CATEGORY  9 / ANIMALS 

C 

C LEVEL  2 
C 

C CAT9  IS  ACCESSED  BY  EIAD  TO  SCHEDULE  INPUTS  TO  THE  CATEGORY 
C RESPONSES  IN  CATEGORY  IX  - ANIMALS?  USING  ABBREVIATED  DISPLAY 
C 

C THE  CALLING  SEQUENCE  IS  ? CALL  CAT9 

C 

C 

C THIS  ROUTINE  WAS  WRITTEN  BY  EASTMAN  AND  MODIFIED  BY  GREEN 
C 

C CLAIM  RELEASE  1*0  - APRIL  1?  1980 

c 

C TEKTRONIX  COMMON 

C 

COMMON  ITEK  (45) 

C 

C LOGICAL  UNITS  AND  COMMON  LOCATION 

C 

COMMON  I ARR Y ( 5 ) ? 1 AR Y2  < 5 ) ? LER  ? LUF  ? LUL 
C 

C POINTERS 

C 

COMMON  EXIT  ? I ANM (3)?ICLI<2)?IGEN<3)? I 6RW ( 5 ) 

COMMON  lOPTN  ? lOVR ( 7 ) ? IPNTR  ? iS0C(6) ? ISUB<8) 

COMMON  ISUR<6) ? 1T0P(9) ? IVEG(2) ?LEXIT  ?LUO 
COMMON  MODE  ?NANM  ?NCLI  ?N6EN  >N6RW 

COMMON  NOVR  ?NSECTS  ?NSOC  ?NSUB  ?NSUR 

COMMON  NIOP  ?NU  ?NVEG 

C 

C GRADING  PARAMETERS 

C 

COMMON  AREA  < 5 ) ? BENLEN  < 5 ? 1 0 ) ? BENW I ( 5 ? 1 0 ) ? COGO  ? GCPA ( 5 ) 

COMMON  GRD MBS  < 5 ) ? HWHT  < 5 ? 1 0 ) ? HWSL I < 5 ? 1 0 ) ? NSPP  < 5 ) ? PCEQl 9 < 4 ) 
COMMON  PERCNT  < 5 ? 1 0 ) ? REHCP Y < 5 ) ? REHVOL ( 5 ) ? SLOPE  < 5 ? 1 0 ) y WBP 
C 

C CATEGORY  TEXT 

C 

COMMON  ANIM(23y 13) yCLMA(13y 13) y GDES ( 15 y 1 3 ) y GWHY < 22 y 13 ) 
COMMON  0VBD(llyl3)ySBSL(13)y  SCEC ( 33 y 13 ) y SWHY ( 44 y 1 3 ) 

COMMON  TPSL<49y  13)  y VGTAdSy  13) 

C 

C EXPECTATION  VALUES 

C 

COMMON  AN I MAL ( 1 3 y 6 ) y CL IMAT  < 8 y 6 ) y 6ENDES ( 8 y 6 ) y GRWH YD  < 1 9 y 6 ) 
COMMON  OVRBDN  < 28  y 6 ) y SOCECN  < 29  y 6 ) y SUBSOl ( 30  y 6 ) y SURHYD ( 23  y 6 ) 
COMMON  T0PS0I(33y6) yVEGETA<10y6) 

C 

C CATEGORY  RESPONSES 

C 
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0055 

0056 

0057 

0058 

0059 

0060 

0061 

0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 

0081 

0082 

0083 

0084 

0085 

0086 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 

0101 

0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


COMMON  RANIMA(3)  jRCLIMA(2)  »R6ENIit;<3)  »RGRWHY<5) 
COMMON  ROORBD ( 7 > 1 0 ) j RSOCEC ( 6 ) t RSUBSO ( 8 ) > RSURHY ( 6 ) 
COMMON  RT0PS0<9) fR0EGET<2) 


I 


C 

C FEASIjTECONjOPUSE  subsystem  parameters 

c 

COMMON  CAAHM  > CABAH  f CABFN ( 3 ) y CABFP ( 3 ) » CABHM 

COMMON  CABS ( 2 ) > CAC » CACP  f CADF , CADH 

COMMON  CADS  j C AEAF » CAHSAF » CAHSTS ^ CAI P 

COMMON  CAR3FC y CASF  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y FAOG  < 5 ) y PFSTSP  y PFAC  y RCLl EC  < 29  y 34 ) 

COMMON  TCAR<5) y THICK(IO) y lHKTSyTTL(40) 

C 

INTEGER  EXI T y CLMA  y GDES  y GWHY  y OOBD y SBSL 
INTEGER  SCEC  y SUHY y TPSL  y VGTA y ANIM 
INTEGER  CLI MAT  y GENDES  y GRWH YD  y OORBDN 
INTEGER  SOCECN  y SUBSOl y SURHYD  y TOPSOI 
INTEGER  OEGETAyANIMAL 


INTEGER  RCL I MA  y RGENDE  y RGRWHY  y ROORBD  y RSOCEC 
INTEGER  RSUBSO  y RSURHY  y RTOPSO  y R0E6E  f y RANIMA 
INTEGER  RCLTECyTTL 


INTEGER  COMMON  (1) 

EQUIVALENCE  (COMMON  (l)y  ITEK  (1)) 


EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 


(lARRY 

(IARY2 

(IARY2 

(IARY2 

(1ARY2 


(1)  y 
<l)y 

(2)  y 

(3)  y 
<4)  y 


LUT) 

ISTRK) 

ISECT) 

ICODE) 

LEN) 


LOGICAL  LER 
C 

C OUTPUT  HEADING 

WRITE  (LUfylOOO)  (ANIM  (lyJ)y  J = lyl3) 

GOTO  (10y20y30)  LEXIT 

C USER  INPUT  ->  IMPORTANT  TYPES  PRESENT 

10  WRITE  (LUTyl020)  ((ANIM  (lyJ)y  J = lyl3)y  1 = 
READ  (LUTy)^:)  RANIMA  (1) 

IF  (RANIMA  (1)«EQ«0)  GOTO  500 
IF  (RANIMA  (1) ♦GE*1*AND*RANIMA  (1)*LE*IANM 
WRITE  (LUfyl015)  RANIMA  (1) 

GOTO  10 


C USER  INPUT  ->  SECONDARY  TYPES  PRESENT 

20  WRITE  (LUTyl020)  ((  ANIM  (lyJ)y  J = lyl3)y  I = 
READ  (LUTy)IO  RANIMA  (2) 

IF  (RANIMA  (2)*EQ*0)  GOTO  500 
IF  (RANIMA  (2) *GE*1 .AND, RANIMA  (2).LE.IANM 
WRITE  (LUTyl015)  RANIMA  (2) 

GOTO  20 


C USER  INPUT  ->  LIVESTOCK  GRAZING 

30  WRITE  (LUTyl020)  ((  ANIM  (lyJ)y  J = lyl3)y  I = 
READ  (LUTy)^)  RANIMA  (3) 

IF  (RANIMA  (3).EQ.O)  GOTO  500 
IF  (RANIMA  (3) *GE.l .AND, RANIMA  (3).LE.IANM 
WRITE  (LUTy  1015)  RANIMA  (3) 

GOTO  30 
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y3) 

1) )  GOTO  20 

20y21) 

2) )  GOTO  30 

16y 17) 

3) )  RETURN 


/ 


I - 

*0111  C USER  WANTS  OUT  ->  SET  EXIT  TO  ZERO  AND  RETURN 

0112  SOO  EXIT  =0  ' 

10113  RETURN 

0114  C FORMAT  STATEMENTS 

0115  1000  FORMAT  </5X>13A2) 

0116  C 

0117  1015  FORMAT  (A2"  ??  ~>  RE-INPUT* *) 

0118  C 

0119  1020  FORMAT  </5Xf 13A2>/5X> 13A2“  -> 

0120  C 

0121  END 

0122  END$ 
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0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 

0053 

0054 
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SUBROUTINE  CLIMA 

C FULL  DISPLAY-CATEGORY  2 / CLIMATOLOGY 

C 

C LEOEL  2 
C 


C CLIMA  IS  ACCESSED  BY  EIFD  TO  SCHEDULE  INPUTS/EDITS  TO 
C CATEGORY  RESPONSESr  AND  EDITS  TO  EXPECTATION  OF  SUCCESS 
C VALUES  TO  CATEGORY  2 - CLIMATOLOGY^  USING  FULL  DISPLAY 
C 


C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

c 

c 

c 


THE  CALLING  SEQUENCE  IS  : CALL  CLIMA 

CLIMA  USES  THE  TCS  ROUTINES  : ERASE  AND  HOME 
THE  LOCAL  VARIABLES  ARE  : 

IANS  ->  ANSWER  CELL 

II  INDEX  t <I,J)  3 TO  CLIMAT  ARRAY 

lOLD  ->  PRE-EDIT  CATEGORY  RESPONSE  VALUE 
LUORN  ->  LAND  USE  OPTION  REFERENCE  NUMBER  I - 

1 ->  CROPLAND 

2 ->  NATIVE  VEGETATION 

3 ->  WILDLIFE 

4 ->  WATER  RECREATION 

5 ->  HIGH  USE 

6 ->  OTHER 

NN  ->  HEADING  NUMBER 

CLIMA  IS  SWAPPED  IN  BY  PROGRAM  CLIMX 
THIS  ROUTINE  WAS  WRITTEN  BY  GREEN 

CLAIM  RELEASE  1*0  - APRIL  1,  1980 


C TEKTRONIX  COMMON 

C 

COMMON  ITEK  (45) 

C 

C LOGICAL  UNITS  AND  COMMON  LOCATION 

C 

COMMON  1ARRY(5) » IARY2(5) y LERj LUF^LUL 
C 

C POINTERS 

C 

COMMON  EXIT  , I ANM < 3 ) » ICLI ( 2 ) r I GEN ( 3 ) ? IGRW ( 5 ) 

COMMON  lOPTN  y I0VR<7) ? IPNTR  » IS0C(6) » IGUBC8) 
COMMON  ISUR(6) > IT0P(9) t IVEG ( 2 ) y LEXIT  yLUO 
COMMON  MODE  ?NANM  »NCL1  yNGEN  yNGRW 

COMMON  NOVR  jNSECTS  yNSOC  yNSUB  yNSUR 

COMMON  NTOP  yNU  yNVEG 

C 

C GRADING  PARAMETERS 

C 
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005t5 

0056 

0057 

0058 

0059 

0060 

0061 

0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 

0081 

0082 

0083 

0084 

0085 

0086 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 

0101 

0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


o 


COMMON  AREA ( 5 ) y 8ENLEN ( 5 » 1 0 ) r BENW I ( 5 » 1 0 ) » COGO  > GCPA ( 5 ) 

COMMON  GRDMBS ( 5 ) > HUNT  < 5 T 1 0 ) T HWSL 1<  5 j 1 0 ) > NSPP ( 5 ) » PCEQ 1 9 ( 4 ) 
COMMON  PERCN7 ( 5 > 10 ) ^ REHCP Y ( 5 ) » REHOOL ( 5 ) > SLOPE ( 5 ? 1 0 ) y WBP 
C 

C CATEGORY  TEXT 

C 

COMMON  ANIM(23y 13) yCLMA(13y 13) yGDES(15y 13) yGWHY(22y 13) 
COMMON  00BD(llyl3)ySBSL(13)y  SCEC < 33 y 13 ) y SWHY ( 44 y 1 3 ) 

COMMON  TPSL<49yl3)yOGTA(15yl3) 

C 

C EXPECTATION  VALUES 

C 

COMMON  AN I MAL ( 1 3 y 6 ) y CL 1 MAT ( 8 y 6 ) y GENBES ( 8 y 6 ) y GRWH YD ( 1 9 y 6 ) 
COMMON  0VRBDN<28y6) yS0CECN(29y6) ySUBS0I(30y6) ySURHYD<23y6) 
COMMON  T0PS0K33y6)  yVEGETA<10y6) 

C 

C CATEGORY  RESPONSES 

C 

COMMON  RANIMA<3) yRCLIMA(2) yRGENBE<3) yRGRWHY(5) 

COMMON  R0VRBB(7y 10) yRS0CEC(6) yRSUBS0(8) yRSURHY<6) 

COMMON  RT0PS0<9) yRVEGET(2) 

C 

C FEASIyTECONyOPUSE  SUBSYSTEM  PARAMETERS 


COMMON  CAAHMyCABAHyCABFN(3) yCABFP(3) yCAHBM 

COMMON  CABS(2) yCACyCACPyCABFyCABH 

COMMON  CABS  y CAE AF  y CAHSAF  y CAHSTS  y CA I P 

COMMON  CAR3FC  y CASF  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y FAVG ( 5 ) y PFSTSP  y PFAC  y RCLTEC ( 29  y 34 ) 


COMMON  TCAR(5) yTHICK(lO) yTHKTSyTTL(40) 


INTEGER  EXI T y CLMA  y GDES  y GWHY  y OVBB  y SBSL 
INTEGER  SCECySUHYy TPSLyVGTAyANIM 
INTEGER  CLIMATy GENBESyGRWHYByOVRBBN 
INTEGER  SOCECNySUBSOIySURHYBy TOPSOI 


INTEGER  VEGETAyANIMAL 

INTEGER  RCLI MA  y R6ENBE  y RGRUHY  y ROVRBB  y RSOCEC 
INTEGER  RSUBSO  y RSURHY  y RTOPSO  y RVEGET  y RANIMA 
INTEGER  RCLTECyTTL 


INTEGER  COMMON  (1) 
EQUIVALENCE  (COMMON  (1) 
EQUIVALENCE  (lARRY  (l)y 
EQUIVALENCE  (1ARY2  (l)y 
EQUIVALENCE  (1ARY2  <2)y 
EQUIVALENCE  (IARY2  <3)y 
EQUIVALENCE  (1ARY2  (4)y 


ITEK  (1)) 
LUT) 

ISTRK) 

ISECT) 

ICOBE) 

LEN) 


C 


LOGICAL  LER 


C 


C DISPLAY  MODE 

1 IF  (♦NOT*LER)  GOTO  5 
CALL  ERASE 
CALL  HOME 

G0T0(10y20y30)  MODE 
WRITECLUfy 1010) 


\ 
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0111 

0112 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120 

0121 

0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 

0161 

0162 

0163 

0164 

0165 

0166 


20 

30 

40 


C 


50 


51 


100 


101 

C 


105 


C 

C 

110 

111 


115 

116 


120 

122 

125 

126 


130 

131 


140 

144 


145 


GOTO  40 

WRITE(LUT >2010) 

GOTO  40 

WRITE(LUT  >3010) 

IF  ( MODE  ♦GT*  1 ) GOTO  50 
GOTO  <100  >200)  LEXIT 

USER  INPUT  -•>  EDIT  HEADING 
WRITE  <LUT>  2020) 

READ  <LUT>  2030)  IANS 

IF  <IANS*EQ»2HA  ) GOTO  100 
IF  < IANS tEQ* 2ND  ) GOTO  200 
IF  <IANS»EQ*2HN0)  RETURN 
WRITE  <LUT>  1200) 

GOTO  51 
NN  = 1 

IF<M0DE,EQ*1)  GOTO  101 
IF(LER)  CALL  ERASE 
IF(LER)  CALL  HOME 

WRITE  (LUT>  1000)  (CLMA  (1>  1)>  I=l>  13) 

DISPLAY  HEADING  A ->  PRECIPITATION 

J=1 

WRITE  (LUT>  1020) 

WRITE  (LUT>  1050)  < <CLMA  (K>  I)>  I=l>  13)>  K=2>  3) 

DO  105  K=4>  7 

WRITE  <LUT>1100)  (CLMA  (K> 1 ) > 1=1 > 13) > (CLIMAT  (J>I)>I=1>6) 

J = J + 1 

GOTO  <140>  130>  110)  MODE 

EDIT  EXPECTATIONS 
USER  INPUT  ->  SUBHEADING  NUMBER 
WRITE  (LUT>  3020) 

READ  <LUT>  t)  II 
GOTO  145 

USER  INPUT  ->  LAND  USE  OPTION  REFERENCE  NUMBER 
WRITE  <LUT>  3030) 

READ  <LUT>  t)  LUORN 

IF  <LU0RN»GE^l*AND*LU0RN»LEt6)  GOTO  120 
WRITE  (LUr>  1200) 

GOTO  116 

GOTO  <125>  122)  NN 
II=II+ICLI  <1) 

USER  INPUT  ~>  EXPECTATION  VALUE 
WRITE  (LUT>  3040) 

READ  (LUT>  CLIMAT  <1I>  LUORN) 

1F<CLIMAT(II>LU0RN) ♦ GE ♦ 0 ♦ AND ♦ CLIMAT < I I > LUORN ) *LE\4)  GOTO  500 
WRITE  (LUT>  3050) 

GOTO  126 

EDIT  CATEGORY  RESPONSES 

I OLD  = RCLIMA  <NN) 

WRITE  (LUf>  2040)  lOLD 
GOTO  144 

INPUT  CATEGORY  RESPONSES 

WRITE  (LUT>  2000) 

READ  <LUT>  RCLIMA  (NN) 

IF  (RCLIMA  (NN)^ECnO)  GOTO  (900>  146)  MODE 
II=RCLIMA  (NN) 

IF  (II.GE,1*AND*1I*LEMCLI  (NN))  GOTO  (600>  500>  115)  MODE 
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I 


0167 

0168 

0169 

0170 

0171 

0172 

0173 

0174 

0175 

0176 

0177 

0178 

0179 

0180 

0181 

0182 

0183 

0184 

0185 

0186 

0187 

0188 

0189 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

0197 

0198 

0199 

0200 

0201 

0202 

0203 

0204 

0205 

0206 

0207 

0208 

0209 

0210 

0211 

0212 

0213 

0214 

0215 

0216 

0217 

0218 

0219 

0220 

0221 

0222 


146  WRITE  <LUT»  1200) 

GOTO  <144y  144»  111)  MODE 
C DISPLAY  HEADING  D ~>  k'lND  VELOCITY 

200  NN=2 

IP  (♦NOT^LER)  GOTO  205 
CALL  ERASE 
CALL  HOME 


WRITE 

(LUT,  1000) 

(CLMA  (1,  I) 

, I 

= 1 , 

13) 

WRITE 

WRITE 

(LUT,  1020) 
(LUT,  1050) 

( (CLMA  (K, 

I)  , 

1 = 1, 

13),  K=8,  9) 

J=ICLI 
DO  210 
WRITE 

(1)  + 1 
K=10,  13 
(LUT,  1100) 

(CLMA  (K, 

I)  , 

1 = 1, 

13),(CLIMAT  (J,  I),  1=1 

210  J=J+1 

GOTO  (140^  130j  110)  MODE 
C USER  INPUT  ->  MORE  EDITS  ? 

500  WRITE  (LUTy  3060) 

READ  <LUT>  2030)  IANS 

IF  <IANS*NE*2HYE)  RETURN 
GOTO  1 

C INPUT  MODE  ->  DIRECT  TO  INDICATED  HEADING 

600  IF  <NN*EQ*NCLI)  RETURN 
GOTO  200 

C USER  WANTS  OUT  ~>  SET  EXIT  TO  ZERO  AND  QUIT 

900  EXIT=0 
RETURN 

C FORMAT  STATEMENTS 

1000  FORMAT  ( 13A2y  44  ( ‘ :♦: ' ) > /»  26Xj 

&10X>  "STANDARD  EXPECTATIONS ‘ r IIXj  •fy  /» 

&26X>  44  Cfyy  /y  26Xy  ")fcCROP)fc‘ f 2Xt 
$"NATIVE",  2Xj  ")*cWILD)^:"  » 2X?  "WATER*  ? 3X» 
&")|«HIGH5f:OTHER-4c*  j /,  26X> 

S")fcLAND:«cVEGETA7I0N)f:LIFDfcRECREATI0N:^cUSE  fy  5Xj  ■>f^") 


C 


1020  FORMAT  (70  <*)*c"),  /,  26X>  " " 4X " " lOX  * * " 4X " " lOX " :<c  MX " " 5X  ‘ :♦(  * ) 


1050  FORMAT  (13A2> 
810X»  •fy  AXy 


•‘fy  AXy  -t-y 


5X>  ")*c") 


if  \L>  ■ 


lOX 


■)^C*,  AXy  ’fy 


1100  FORMAT  (13A2> 
"II"  * 


•11" 


II"  t 


"II" 


)tc  *11 


C 


1200  FORMAT  (/"YOU  HAVE  TYPED  IN  AN  ILLEGAL  ANSWER* 
l/y  "GIVE  HER  ANOTHER  SHOT  ~>  _") 


*11" 


2000  FORMAT  ("ENTER  7HE  APPROPRIATE 


4X 


C 


lAA  i‘f)y  /y  "NUMBER,  OR  ZERO  TO  QUIT 
1010  FORMAT  ( 17X" INPUT  RESPONSES/CL IMATOLOG 


_"  ) 


\/  ■ / / 
I / / 


2010  FORMAT  ( 17X"EDIT  RESPONSES/CLIMATOLOGY"//)  ^ 

3010  FORMAT  ( 17X"ED1T  EXPECTATIONS/CLIMATOLOGY"//) 

2020  FORMAT  (/,  5X"IN  WHICH  HEADING  IS  YOUR  DESIRED  EDIT?"/, 
&5X"  (ENTER  A,  B,  OR  NONE)  ->  _") 
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0223  C 

0224  2030  FORMAT  (A2) 

0225  C 

0226  2040  FORMAT  </»  5X'Y0UR  CURRENT  RESPONSE  IS  ->•'11  ^ //» 

0227  &5X* ENTER  YOUR  NEW  RESPONSE  HERE  -> 

0228  C 

0229  3020  FORMAT  </»  5X'IN  WHICH  SUB-HEADING  IS  THE  EXPECTATION  OALUEVr 

0230  &5X‘Y0U  WISH  TO  CHANGE  ? (ENTER  THE  APPROPRIATE  NUMBER)  ->  _*) 

0231  C 

0232  3030  F0RMAT(/5X'SELECT  THE  LAND  USE  OPTION  YOU  WISH  TO  CHANGE'/ 

0233  > IX'  -1-  / -2-  / -3-  / -4-  / -5-  / -6-  /'/ 

0234  > IX' CROPLAND/NAT ♦UEG* /WILDLIFE/WAT. RECt /HIGH  USE/  OTHER/' 

0235  >/5X' ENTER  YOUR  SELECTION  HERE  ->  _') 

0236  C 

0237  3040  FORMAT  (/,  SX'ENTER  YOUR  NEW  EXPECTATION  UALUE  HERE  ->  _') 

0238  C 

0239  3050  FORMAT  (/»  SX'ERROR— > YOUR  EXPECTATION  VALUE  MUST  BE'/r 

0240  ♦♦♦♦♦&5X'0j1>2j3t  OR  4 TO  AVOID  INTRODUCING  A BIAS  ->  ^') 

0241  C 

0242  3060  FORMAT  (/?  5X'ANY  MORE  EDITS  TO  CLIMATOLOGY  ?'/j 

0243  S5X'  (YES  OR  NO)  ->  _') 

0244  C 

0245  END 

0246  END$ 
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tool 
002 
0003 
mooA 
|)005 
0006 
^007 

mooB 

%009 

0010 

toil 
012 
0013 

(014 
01^ 
0016 
^017 
1)018 
%019 
0020 

i)021 
)022 
0023 
|024 


025 


I 


0026 

^027 

§028 

^029 

0030 

1031 
032 
0033 
034 
035 
0036 

«037 
038 
039 
0040 

1041 
042 
0043 

1044 
045 
0046 

«047 
048 
049 
0050 
051 


I 


052 
0053 
«054 
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SUBROUTINE  CNORT  ( UALUE j RVALUE ) 

C 

C LEVEL  6 
C 

C CNVRT  IS  ACCESSED  BY  FIXLN  TO  CONVERT  ‘VALUE' j A REAL 
C NUMBER  IN  THE  RANGE  0 - 100 > TO  A CHARACTER  STRING 
C REPRESENTATION  OF  THAT  VALUE  < 'RVALUE') 

C 

C THE  CALLING  SEQUENCE  IS  t 
C 

C CALL  CNVRT < VALUE > RVALUE) 

C 

C WHERE 
C 

C VALUE  IS  THE  VALUE  TO  BE  CONVERTED 

C RVALUE  IS  THE  CHARACTER  STRING  ARRAY 

C 

C ‘INDEX'  CONTAINS  THE  CHARACTER  REPRESEN f ATIONS  OF  THE  DIGITS  0-9 
C “VAL'  IS  ASSIGNED  THE  VALUE  OF  'VALUE'  SO  THAT  'VALUE'  DOESN'T  CHANGE 
C 'RVAL'  IS  THE  CURRENT  DIGIT  BEING  HANDLED 
C 

C THIS  ROUTINE  WAS  WRITTEN  BY  GREEN 
C 

C CLAIM  RELEASE  1*0  - APRIL  1j  1980 

C 

INTEGER  RVALUE<6) ,1NDEX(10) 

DATA  INDEX/1H0j1H1,1H2j 1H3,1H4^1H5»1H6»1H7j1H8^1H9/ 

C 

C FILL  'RVALUE'  WITH  BLANRS 

DO  10  R=ly6 

RVALUE(R)=1H 
10  CONTINUE 

C IF  'VALUE'  IS  ZERO»  WE'RE  DONE* 

C OTHERWISE,  SET  'VAL'  AND  FIX  THE  DECIMAL* 

IF(VALUE*EQ*0* ) RETURN 
RVALUE(4)=1H* 

VAL  = VALUE 

C IF  'VAL'  IS  100,  WE  NEED  6 CELLS 

IF(VAL*NE*100* ) GOTO  20 
RVALUE(1)=1H1 
DO  15  R=2,6 

1F(RVALUE(R) *EQ*1H  ) RVALUE(R)=1H0 
15  CONTINUE 
RETURN 

C START  WITH  THE  'TENS'  PLACE 

20  RVAL=IFIX(VAL/10* ) 

RVALUE ( 2 ) = I NDEX ( RVAL+ 1 ) 

IF(RVAL*EQ*0)  GOTO  25 
VAL  = VAL  - FLOAT(RVAL)fclO) 

C NOW  DO  THE  'ONES'  PLACE 

C TARE  CARE  OF  BINARY  MISREPRESENTATION 

25  RVAL=IFIX(VAL) 

RVALUE  < 3 ) = INDEX  < RVAL+ 1 ) 


005S 

0056 

0057 

0058 

0059 

0060 

0061 

0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 


1K(K0AL*E:Q.0)  goto  30 

OAL  = (VAL  - FLOAT(KVAL)  + *00005)  t 10* 

GOTO  35 

30  OAL  = OAL  t 10*  + *00005 
C NOW  THE  ‘TENTHS*  PLACE 

35  KVAL=IFIX<VAL) 

KOALUE  < 5 ) = I NDEX  < KOAL+ 1 ) 

IF(KVAL*EQ*0)  GOTO  40 

VAL  = (VAL  - FLOAT(KOAL))  t 10* 

GOTO  45 

40  OAL  = OAL  t 10* 

C FINALLY?  THE  * HUNDRETHS * PLACE  AND  RETURN 

45  K0ALUE(6)=1NDEX(IFIX(UAL)+1) 

RETURN 

END 

END$ 
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0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 


FTN4 

C 

C LABEL  COMMON  CTIL  (CATEGORY  TITLES)  tt 

C 

BLOCK  DATA  CTIL 
COMMON  /CTIL/  ICAT 
INTEGER  ICAT  (IO7I2) 

DATA  ICAT  / 


2HGE 

?2HCL 

j2HT0 

»2HSU 

y2H0U 

»2HSU 

»2HGR 

j2H0E 

y2HAN 

y2HS0 

2HNE 

,2HIM 

j 2HPS 

>2HBS 

>2HER 

j2HRF 

>2H0LI 

j2HGE 

y2HIM 

y2HCI 

% 

2HRA 

j2HAT 

>2H0I 

?2H0I 

?2HBU 

j 2HAC 

»2HND 

?2HTA 

y2HAL 

t2H0- 

2HL 

j2H0L 

j2HL 

f 2HL 

y 2HRD 

?2HE 

f2H  U 

y 2HTI 

y2HS 

y2HEC 

2HDE 

y2H0G 

>2H 

,2H 

j2HEN 

,2HUA 

j2HAT 

t2H0N 

y2H 

y2H0N 

2HSC 

j2HY 

f2H 

j2H 

?2H 

,2HTE 

j2HER 

y2H 

y2H 

y2H0M 

s. 

2HRI 

f 2H 

,2H 

y2H 

j2H 

j 2HR 

f2H  H 

y2H 

j2H 

y2HIC 

2HPT 

y2H 

j2H 

>2H 

j2H 

j2HHY 

>2HYD 

y2H 

y2H 

y2HS 

> 

2HI0 

j2H 

f2H 

>2H 

t2H 

f2HDR 

> 2HR0 

y2H 

y2H 

y2H 

2HN 

f2H 

f2H 

j2H 

j2H 

>2H0L 

»2HL0 

y2H 

j2H 

y2H 

> 

2H 

»2H 

,2H 

j2H 

j2H 

j2H0G 

,2HGY 

y2H 

y2H 

y2H 

> 

2H 

>2H 

f2H 

y2H 

>2H 

>2HY 

j2H 

y2H 

y2H 

y2H 

END 

END$ 
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SlfCDSl  T=00004  IS  ON  CR00015  USING  00069  BLKS  R=0000 


0001  FTN4 

0002  C ====t===.==:===:====:==:=:===  SUBROUTINE  DCBSl 

0003  C = 

0004  C = DISPLAY  CURRENT  DATA  SET  (SEGMENT  ONE) 

0005  C = 


0006  C = SOURCE  FILE:  &DCDS1  OBJECT  FILE:  %DCDS1 

0008  C 

0009  C 

0010  c description: 

0011  c 

0012  C DCDSl  DISPLAYS  THE  CURRENT  DATA  FOR  CATEGORIES  1 THROUGH  5 

0013  C DCDSl  IS  SCHEDULED  THROUGH  CLAIM  SWAP  CONTROL  VIA  PROGRAM  DCDSX 

0014  C 

0015  C CALLING  SEQUENCE: 

0016  C 

0017  C CALL  DCDSl 

0018  C 

0019  c arguments:  none 

0020  C 

0021  C ACCESSED  BY: 

0022  C 

0023  C CLAIM 

0024  C RCLAM  (SEAMPLAN) 

0025  C 

0026  C SUBROUTINES  SCHEDULED: 

0027  C 

0028  C ERASE  (TCS) 

0029  C HOME  (TCS) 

0030  C OTSPL  (SYS) 

0031  C 

0032  C LABEL  COMMON  DECLARATIONS  : 

0033  C 

0034  C ALTRN 

0035  C 

0036  C LOCAL  VARIABLES: 

0037  C 

0038  C STARTn  ~>  STARTING  WORD  FOR  TEXTEC  ARRAY  (n  =>  CATEGORY  #)( INTEGER) 

0039  C STOPn  ~>  END  WORD  FOR  TEXTEC  ARRAY  (INTEGER) 

0040  C CHNG  ->  HEADING  LETTER  CHANGES  (INTEGER) 

0041  C LU  ~>  LU  RETURN  BY  OTSPL 

0042  C 

0043  C author:  ORVILLE  D.  GREEN 

0044  C 

0045  C CLAIM  RELEASE  1*0  - APRIL  1,  1980 

0046  C 

0047  C 

0049  C 

0050  C 

0051  SUBROUTINE  DCDSl 

0052  C 

0053  C 

0054  C TEKTRONIX  COMMON 
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COMMON  ITEK  (45) 


0055 

0056 

0057 

0058 

0059 


C 

C 

C 

C 


LOGICAL  UNITS  AND  COMMON  LOCATION 


0060 

0061 

C 

COMMON 

1ARRY<5 

)ylARY2< 

5)  yLERyLUFyLUL 

0062 

C 

POINTERS 

0063 

0064 

C 

COMMON 

EXIT 

y IANM<3) 

y ICLI<2) y IGEN(3) 

y IGRU(5) 

0065 

COMMON 

lOPTN 

y I00R(7) 

yIPNTR  yIS0C(6) 

y ISUB(8) 

0066 

COMMON 

ISUR(6) 

yIT0P(9) 

y I0EG(2) yLEXIT 

yLUO 

0067 

COMMON 

MODE 

yNANM 

yNCLl  yNGEN 

y NGRW 

0068 

COMMON 

NOOR 

yNSECTS 

yNSOC  yNSUB 

yNSUR 

0069 

COMMON 

NTOP 

yNU 

yNOEG 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 
0081 
0082 

0083 

0084 

0085 

0086 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 
0101 
0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


C 

C 

C 


C 

C 

C 


C 

C 

C 


C 

c 

c 


c 

c 

c 


GRADING  PARAMETERS 

COMMON  AREA < 5) » BENLEN < 5 » 10 ) j BENWI < 5 ^ 10 ) y COGO j GCPA ( 5 ) 

COMMON  GRDOBS  < 5 ) > HWHT ( 5 j 1 0 ) » HWSL 1 ( 5 ? 1 0 ) ^ NSPP ( 5 ) y PCEQ 1 9(4) 
COMMON  PERCNT(5> 10) , REHCPY ( 5 ) , REHVOL ( 5 ) , SLOPE ( 5 y 10 ) > WBP 

CATEGORY  TEXT 

COMMON  ANIM(23,13) fCLMA( 13^13 )> GOES (15^13 ) yGUHY<22» 13) 
COMMON  OOBDdly  13)  jSBSL<13)  j SCEC  < 33  d3 ) ^ SWHY  ( 44  d3  ) 

COMMON  TPSL(49d3)>0GTA<15d3) 

EXPECTATION  OALUES 

COMMON  ANIMAL(13>6) >CLIMAT(8?6) yGENDES(8»6) > GRWHYLK  19> 6) 
COMMON  00RBDN(28>6)  ?S0CECN<29y  6)  ySUBS0K30?6)  ? SURHYD < 23 y 6 ) 
COMMON  T0PS0I(33j6) >0EGETA(10»6) 

CATEGORY  RESPONSES 

COMMON  RANIMAC3)  yRCLlMA(2)  yRGENDE(3)  rRGRk»HY(5) 

COMMON  ROORBD<7dO)  ? RS0CEC<6)  y RSUBS0<8)  yRSURHY<6) 

COMMON  RT0PS0(9) yRVEGET<2) 

FEASIyTECONyOPUSE  SUBSYSTEM  PARAMETERS 

COMMON  CAAHMyCABAHyCABFN(3) yCABFP<3) yCABHM 

COMMON  CABS<2) yCACyCACPyCADFyCADH 

COMMON  CADS  y CAEAF  y CAHSAF  y CAHSTS  y CAIP 

COMMON  CAR3FCyCASFyCASNCyCSTESyCSTRM 

COMMON  CSTRP  y FAUG  < 5 ) y PFSTSP  y PFAC  y RCLTEC  < 29  y 34 ) 

COMMON  TCAR<5) yTHICK(lO) yTHKTSyTTL(40) 

INI  EGER  EXI T y CLMA  y GDES  y GWHY  y OUBD  y SBSL 
INTEGER  SCECySWHYy TPSLyUGTAyANIM 
INI  EGER  CL I MAT  y GENDES  y GRWH YD  y OMRBDN 
INI  EGER  SOCECN  y SUBSOI y SURHYD  y TOPSOI 
INTEGER  VEGETAyANIMAL 

INTEGER  RCL I MA  y RGENDE  y RGRWHY  y ROMRBD  y RSOCEC 
INI  EGER  RSUBSOyRSURHYyRTOPSOy RUEGETyRANIMA 
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INTEGER  RCLTECjTTL 


0111 

0112  C 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120  C 

0121 

0122  C 

0123 

0124 

0125 

0126 

0127 

0128  C 

0129 

0130 

0131 

0132 

0133 

0134  C 

0135 

0136 

0137 

0138 

0139 

0140  C 

0141 

0142  C 

0143  C 

0144  C 

0145 

0146 

0147 

0148 

0149  C 

0150 

0151 

0152 

0153 

0154  C 

0155  C 

0156  C 

0157 

0158 

0159 

0160 
0161 
0162 

0163 

0164 

0165 

0166 


INTEGER  COMMON  <1) 

EQUIVALENCE  (COMMON  (Dr  ITEK 
EQUIVALENCE  (lARRY  (1)j  LUT) 
EQUIVALENCE  (IARY2  <1)>  ISTRK) 
EQUIVALENCE  (IARY2  <2)y  ISECT) 
EQUIVALENCE  (1ARY2  (3)r  ICODE) 
EQUIVALENCE  (IARY2  <4)»  LEN) 


(1)  ) 


LOGICAL  LER 


COMMON  /ALTRN/  ALTN 

INTEGER  STARTl (3) r START2 < 2 ) > START3 ( 9 ) r START4 ( 7 ) ?START5<5) 
INTEGER  SfOPl<3) t ST0P2 < 2 ) > ST0P3 ( 9 ) » ST0P4 ( 7 ) y ST0P5 ( 5 ) 
INTEGER  CHNG  <8)>  ALTN  <6y4) 

DIMENSION  LINE  (74) 


DATA  STARTl  /Iy5yl0  / 

DATA  START2  /ly8  / 

DATA  START3  /I y 7 y 12 y 19 r 24 y 28 y 34 y 40 y 45  / 

DATA  START4  /12 y 19 y 24 y 28 y 34 y 40 y 45  / 

DATA  STARTS  /24 y 28 y 34 y 40 y 45  / 

DATA  STOPl  /2y6yl2  / 

DATA  ST0P2  /3y9  / 

DATA  ST0P3  /2 y 8 y 12 y 20 y 25 y 28 y 35 y 4 1 y 46  / 

DATA  ST0P4  /12 y 20 y 25 y 28 y 35 y 4 1 y 46  / 

DATA  ST0P5  /25 y 28 y 35 y 41 y 46  / 

DATA  CHNG/2H  Ay2H  By2H  Cy2H  Dy2H  Ey2H  Fy2H  Gy2H  H/ 

SPOOL  OUTPUT 

IF  (LUL  *EQ*  LUT)  GOTO  1 
CALL  OTSPL  (LUy  1) 

IF  (LU  *LT*  0)  GOTO  5000 
LUL  = LU 


1 IF  (*NOT*  LER  ♦OR*  LUL  ♦NE*  LUT)  GOTO  2 
CALL  ERASE 
CALL  HOME 
KPASS=0 


GENERAL  DESCRIPTION  CATEGORY 

2 WRITE  (LULy  1000)  TTL 
WRITE  (LULy  1001) 

1 PLACE  = 0 

IF(RGENDEd)  ♦EQ*0)  WRITE  (LULy  1900) 
IF(RGENDE(1 ) ♦EQ»0)  CALL  BELL 
IF(RGENDEd)  ♦EQ*0)  CALL  TINPTdCHAR) 
IF(RGENDEd)  ♦EQ*0)  GOTO  100 
DO  10  JJ=lyNGEN 

IF(RGENDE( JJ) *EQ*0)  WRITE  (LULy2000) 
IF(RGENDE( JJ) *EQ*0)  CALL  BELL 
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0167 

0168 

0169 

0170 

0171 

0172 

0173 

0174 

0175 

0176 

0177 

0178 

0179 

0180 

0181 

0182 

0183 

0184 

0185 

0186 

0187 

0188 

0189 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

0197 

0198 

0199 

0200 

0201 

0202 

0203 

0204 

0205 

0206 

0207 

0208 

0209 

0210 

0211 

0212 

0213 

0214 

0215 

0216 

0217 

0218 

0219 

0220 

0221 

0222 


IF  <RGt"NDE(  JJ)  ♦EQ^O)  CALL  TINPT(  ICHAR) 

IF(R6ENDE( JJ) *EQ»0)  GOTO  100 
8 WRITE (LULy 1010)  < (6DES<Ky 1 ) » 1=1 , 13) > K=START1 ( JJ) , STOPl ( JJ) ) 
WRITE (LUL» 1020)  ( GDES ( RGENOE ( J J ) TSTOPl ( JJ ) > I ) , 1=1 , 13) y 
& ( GENDES ( R6ENDE ( J J ) +IPLACE  j I ) » I = 1 y 6 ) 

, 10  IPLACE  = IPLACE  + 16EN<JJ) 

URITECLULy 1030)  CSTES 
WRITECLULy 1002) 

IF  (LUL  .EQ*  LU)  GOTO  15 
WRITE  <LUTyl035) 

READ  <LUTyl036)  IANS 
IF  (IANS  ♦EQ*  IHX)  GOTO  5000 
IF  (LER)  CALL  ERASE 
IF  (LER)  CALL  HOME 
C 

C OUTPUT  THE  APPROPRIATE  GRADING  VARIABLES 

C 

15  GOTO  (20y75)  RGENDE  (1) 

C 

C DRAGLINE  MINE 

C 

20  GOTO  (30y40y50)  RGENDE  (2) 

C 

C OPENING  CUT  / DRAGLINE  MINE 

C 

30  WRITE  (LULyl040)  (GRDOBS  (I)y  I = ly  4)y  COGO 
GOTO  55 
C 

C MINE  RUN  / DRAGLINE  MINE 

C 

40  WRITE  (LULyl050)  (6RD0BS  (I)y  I = ly  4)y  COGO 
GOTO  55 
C 

C FINAL  CUT  / DRAGLINE  MINE 

C 

50  WRITE  (LULyl060)  BYy  GRDVBSyCOGO 

55  IF  (LUL  *EQ*  LU)  GOTO  60 
WRITE  (LUfyl035) 

READ  (LUfyl036)  IANS 
IF  (IANS  ♦EQ.  IHX)  GOTO  5000 
C 

60  IF  (LUL  ♦EQ»  LUT  ♦AND.  LER)  CALL  ERASE 

IF  (LUL  .EQ.  LUT  .AND.  LER)  CALL  HOME 

IF  (LUL  .EQ.  LU)  WRITE  (LULy62) 

WRITE  ( LUL y 2010)  ( (ALTN(Ky J) y J=1 y 4 ) y K=1 y 5 ) 

KPAIR=1 

61  CALL  FIXLN(SLOPEyPERCNTyNSPPyKPAIRyLINE) 

WRITE(LULy2011)  LINE 

DO  63  1=1 y5 

IF(NSPPd)  .LE.KPAIR)  GOTO  63 
KPAIR  = KPAIR  + 1 
GOTO  61 

63  CONTINUE 

WRITE  (LULy2012) 

IF  (LUL  .EQ.  LU)  GOTO  100 
WRITE  (LUTyl035) 
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0223 

0224 

0225 

0226 

0227 

0228 

0229 

0230 

0231 

0232 

0233 

0234 

0235 

0236 

0237 

0238 

0239 

0240 

0241 

0242 

0243 

0244 

0245 

0246 

0247 

0248 

0249 

0250 

0251 

0252 

0253 

0254 

0255 

0256 

0257 

0258 

0259 

0260 

0261 

0262 

0263 

0264 

0265 

0266 

0267 

0268 

0269 

0270 

0271 

0272 

0273 

0274 

0275 

0276 

0277 

0278 


READ  (LUr>1036)  IANS 
IF  (IANS  *EQ*  IHX)  5000»  100 


C 

C 

C 


C 

C 

C 


TRUCK  AND  SHOOEL  TYPE  MINE 


75 


78 


85 


DO  95 
IF 
WRITE 
DO  78 
WRITE 

r 

WRITE 
WRITE 
DO  85 
WRITE 


LUO  = 1?  5 

<NSPP<LUO) »EQ*0)  GOTO  95 
(LULy77)  (ALTN  (LUO> J) > J=1 ^4) 

I = 1 > NSPP  (LUO) 

<LUL»79)  1^  HWSLl  (LUO»I)yHWHT 
DENLEN  (LUO, I) 

(LUL,80)  COGOjAREA  (LU0),REH00L 
(LUL,82) 

1=1,  NSPP  (LUO) 

(LUL,86)  I,  SLOPE  ( LUO , I ) , PERCNT 


(LUO,I) ,BENWI  (LU0,1), 


(LUO),REHCPY  (LUO) 


(LUO, I) 
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IF  (LUL  ♦EQ.  LU)  GOTO 
WRITE  (LUf,1035) 

READ  (LUT,1036)  IANS 
IF  (IANS  *EQ*  IHX)  GOTO 
IF  (LER)  CALL  ERASE 
IF  (LER)  CALL  HOME 
CONTINUE 

CLIMATOLOGY  CATEGORY 


95 


.000 


100  IF  (LUL  ♦ECK  LUT  ♦AND*  LER)  CALL  ERASE 
IF  (LUL  *EQ*  LUT  *AND*  LER)  CALL  HOME 
WRITE  (LUL, 1000)  TTL 
WRITE  (LUL, 1001) 

I PLACE  = 0 
DO  110  JJ=1,NCLI 

IF(RCLIMA( JJ) *EQ*0)  GOTO  5000 

107  WRITE  (LUL, 1010)  ( (CLMA  (K, I ) , 1=1 , 13) ,K=START2( JJ) ,ST0P2( JJ) ) 

WRITE  (LUL, 1020)  (CLMA  (RCLIMA  ( JJ)+ST0P2( JJ) , I ) , 1=1 , 13) , 

S (CLIMAT  (RCLIMA  ( JJ)+IPLACE, I ) , 1=1 ,6) 

110  IPLACE  = IPLACE  + ICLI  (JJ) 

WRITE  (LUL, 1002) 

IF  (LUL  ♦EQ*  LU)  GOTO  120 
WRITE  (LUT, 1035) 

READ  (LUT, 1036)  IANS 
IF  (IANS  ♦EQ*  IHX)  GOTO  5000 

IF  (LER)  CALL  ERASE 

IF  (LER)  CALL  HOME 


C 

C TOPSOIL  CATEGORY 

C 


120  WRITE  (LUL, 1000)  TTL 
WRITE  (LUL, 1001) 

IPLACE  =0 
DO  135  JJ=1,NT0P 

IF(RTOPSO( JJ) ♦EQ^O)  GOTO  5000 

130  WRITE  (LUL, 1010)  ( (TPSL  (K, I ) , 1=1 , 13) ,K=START3( JJ) ,ST0P3( JJ) ) 

WRITE  (LUL, 1020)  (TPSL  (RTOPSO  ( JJ)+ST0P3( JJ) , 1 ) , 1=1 , 13) , 

& (TOPSOI  (RTOPSO  (JJ)+IPLACE,I) ,1=1,6) 

IF  (LUL  ♦EO*  LU)  GOTO  135 

IF  (JJ  ♦EQ*  3 *0R*  JJ  ♦EQ*  6 *0R*  JJ  ♦EQ»  8)  132,  135 
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0279 

0280 

0281 

0282 

0283 

0284 

0285 

0286 

0287 

0288 

0289 

0290 

0291 

0292 

0293 

0294 

0295 

0296 

0297 

0298 

0299 

0300 

0301 

0302 

0303 

0304 

0305 

0306 

0307 

0308 

0309 

0310 

0311 

0312 

0313 

0314 

0315 

0316 

0317 

0318 

0319 

0320 

0321 

0322 

0323 

0324 

0325 

0326 

0327 

0328 

0329 

0330 

0331 

0332 

0333 

0334 


132  WRITE  (LUfy  1002) 

WRITE  (LUTf  1035) 

READ  (LUTt  1036)  IANS 
IF  (IANS  *EQ*  IHX)  GOTO  5000 
IF  (LER)  CALL  ERASE 
IF  (LER)  CALL  HOME 
WRITE  (LUT»  1000)  TTL 
WRITE  (LUTj  1001) 

WRITE  (LOT,  1010)  (TPSL  (Ifl)f  1=1,  13) 

135  IPLACE  = IPLACE  + ITOP  (JJ) 

WRITE  (LULrllOO)  CSTRM , CSTRP , THKTS 
WRITE  (LUL,1002) 

IF  (LUL  .EQ*  LU)  GOTO  140 
WRITE  (LUr,1035) 

READ  (LOT, 1036)  IANS 
IF  (IANS  *EQ,  IHX)  GOTO  5000 
IF  (LER)  CALL  ERASE 
IF  (LER)  CALL  HOME 
C 

C SUBSOIL  CATEGORY 

C 

140  WRITE  (LUL, 1000)  TTL 
WRITE  (LUL, 1001) 

IPLACE  =0 

IF(RSUBS0(1)  tEtKO)  GOTO  5000 
WRITE  (LUL, 1010)  (SBSL  (I), 1=1, 13) 

WRITE  (LUL, 1010)  (TPSL  ( 2, I ) , 1=1 , 13 ) 

WRITE  (LUL, 1020)  (TPSL  (RSUBSO  ( 1 )+2, I ) , 1=1 , 13) , 

X (SUBSOI  (RSUBSO  ( 1 ) , I ) , 1=1 , 6) 

DO  150  JJ=2,NSUB 

IF(RSUBSO( JJ) *EQ*0)  GOTO  5000 

WRITE  (LUL, 1015)  CHNG  (JJ),  (TPSL  ( START4 ( JJ-1 ) , I ) , 1=2 , 13 ) 

IF  (START4(  JJ-1)  *EQ.  ST0P4(JJ-D)  GOTO  148 

WRITE (LUL, 1010) ( ( TPSL ( K , I ) , 1=1 , 13 ) , K=START4 ( J J-1 ) +1 , ST0P4 ( JJ-1 ) ) 

148  WRITE  (LUL, 1020)  (TPSL  (RSUBSO  ( JJ)+ST0P4( JJ-1 ) , I ) , 1=1 , 13) , 

& (SUBSOI  (RSUBSO  ( JJ ) +IPLACE , I ) , 1=1 , 6 ) 

IF  (LUL  ♦EQ*  LU)  GOTO  150 

IF  (JJ  ♦EQ*  3 ♦OR,  JJ  ,EQ,  6)  149,  150 

149  WRITE  (LUT,  1002) 

WRITE  (LUT,  1035) 

READ  (LUT,  1036)  IANS 

IF  (IANS  ,E0*  IHX)  GOTO  5000 
IF  (LER)  CALL  ERASE 
IF  (LER)  CALL  HOME 
WRITE  (LUT,  1000)  TTL 
WRITE  (LUT,  1001) 

WRITE  (LUT,  1010)  (SBSL  (I),  I = 1,13) 

150  IPLACE  = IPLACE  + ISUB  (JJ) 

WRITE  (LUL, 1002) 

IF  (LUL  ,EQ,  LU)  GOTO  160 
WRITE  (LUT, 1035) 

READ  (LUT, 1036)  IANS 
IF  (IANS  ,EQ,  IHX)  GOTO  5000 
IF  (LER)  CALL  ERASE 
IF  (LER)  CALL  HOME 
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0335 

0336 

0337 

0338 

0339 

0340 

0341 

0342 

0343 

0344 

0345 

0346 

0347 

0348 

0349 

0350 

0351 

0352 

0353 

0354 

0355 

0356 

0357 

0358 

0359 

0360 

0361 

0362 

0363 

0364 

0365 

0366 

0367 

0368 

0369 

0370 

0371 

0372 

0373 

0374 

0375 

0376 

0377 

0378 

0379 

0380 

0381 

0382 

0383 

0384 

0385 

0386 

0387 

0388 

0389 

0390 


C OVERBURDEN  CATEGORY 


C 


160  IF(R0VRBD(1>1) ♦EQ.O) 
DO  180  KK=1>NU 
IPLACE  = 0 

WRITE  <LUL,1000)  TTL 
WRITE  (LULjIOOI) 
WRITE  (LULj1120) 
WRITE  <LUL>1010) 
WRITE  (LUL>1020) 


GOTO  5000 


KK 

( (OVBD  (K>I),I=l»13)»K=ly3) 

(OVBD  (ROVRBD  ( 1 >KK)+3> I ) y 1=1 , 13) » 


& (OVRBDN  (ROVRBD  ( 1 y KK ) » I ) y I =1 y 6 ) 

WRITE  (LULyll30)  THICK  <KK) 

IF(R0VRBD(2yKK) ♦EQ*0)  GOTO  5000 
WRITE  (LULylOlO)  ( <OVBD  ( K y I ) y 1=1 y 13 ) y K=8y 10 ) 

WRITE  (LULyl020)  (TPSL  (ROVRBD  < 2 y KK ) +12 y I ) y I =1 y 1 3 ) y 
& (OVRBDN  (ROVRBD  (2yKK)+I0VR  ( 1 ) y I ) y 1= 1 y 6 ) 


DO  170  JJ=3yN0VR 

IF(ROVRBD( JJyKK) ♦EQ^O)  GOTO  5000 
WRITE  <LULyl015)  CHNG  (JJ+l)y  (TPSL  < STARTS ( J J-2 ) y I ) y 1=2 y 13 ) 
IF  (START5( JJ-2)  ♦ECU  ST0P5(JJ-2))  GOTO  167 


WRITE(LULy 1010) ( (TPSL(Ky I) y I=ly 13) yK=START5( JJ-2)+lyST0P5< JJ-2) ) 

167  WRITE (LULy 1020)  ( TPSL ( ROVRBD < J J y KK ) +ST0P5 < JJ~2 ) y I ) y 1=1 y 13) y 

& (OVRBDN  (ROVRBD  ( JJy KK)+IPLACEy I ) y 1=1 y 6) 

IF  (LUL  ♦ECU  LU)  GOTO  170 

IF  <JJ  ♦EQ^  3 ♦OR^  JJ  ♦EQ^  6)  168y  170 

168  WRITE  (LUfy  1002) 

WRITE  (LUTy  1035) 

READ  (LUTy  1036)  IANS 

IF  (IANS  ♦£□♦  IHX)  GOTO  5000 
IF  (LER)  CALL  ERASE 
IF  (LER)  CALL  HOME 
WRITE  (LUTy  1000)  TTL 
WRITE  (LUTy  1001) 

WRITE  (LUTy  1010)  (OVBD  (lyl)yl  = ly  13) 

170  IPLACE  = IPLACE  + lOVR  (JJ) 

WRITE  (LULy 1002) 

IF  (LUL  ♦£□♦  LU)  GOTO  180 
WRITE  (LUTy 1035) 

READ  (LUfy 1036)  IANS 
IF  (IANS  ♦EQ^  IHX)  GOTO  5000 
IF  (LER)  CALL  ERASE 
IF  (LER)  CALL  HOME 
180  CONTINUE 
KPASS  = 1 
C 

C OUIT  OTSPL  AND  RETURN 

C 

5000  IF(KPASS^EQ^0*AND^IANS*NE^1HX)  WRITE  (LULy 2001) 

IF(IANS^ECU2HX  ♦ OR ♦ KPASS ♦ EQ ♦ 0 ) EXIT  = -1 

IF  (LUL  ♦ECU  LUT)  GOTO  5001 
CALL  OTSPL  (LUy2) 

RETURN 

5001  IF(KPASS^ECUO^AND^IANS^NE^IHX)  CALL  BELL 
IF(KPASS^EQ^O^AND^IANS^NEMHX)  CALL  TINPT  (ICHAR) 


RETURN 


C 
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0391 

0392 

0393 

0394 

0395 

0396 

0397 

0398 

0399 

0400 

0401 

0402 

0403 

0404 

0405 

0406 

0407 

0408 

0409 

0410 

0411 

0412 

0413 

0414 

0415 

0416 

0417 

0418 

0419 

0420 

0421 

0422 

0423 

0424 

0425 

0426 

0427 

0428 

0429 

0430 

0431 

0432 

0433 

0434 

0435 

0436 

0437 

0438 

0439 

0440 

0441 

0442 

0443 

0444 

0445 

0446 


C FORMAT  STATEMENTS 

C 

1000  FORMAT  <1H1> 

&1X»40A2j/ 

LIST  OF  RESPONSES  TO  ENVIRONMENTAL “ IX 
^•FEASIBILITY  CATEGORIES  ttf) 

C 

1001  FORMAT  < /,10X"  RESPONSE  * 12X • EXPECTATION " IX 

&'0F  SUCCESS  VALUES"/? 

X lOX* -12X- 'IX 

j;. ./? 

>32X  • /CROP/NAT  ♦ /U«I LD/UAT . /HIGH/OTHER/ " / ? 

>32X • /LANB/VEG ♦ /LIFE/REC ♦ /USE  / / “ / 

>1X?73  (•=•)/) 

C 

1010  FORMAT  (4X?13A2) 

C 

1020  FORMAT  < 1X*)|C3|C- IX?  13A2?  5X?  II  ?5  (4X?I1)/) 


C 

1030  FORMAT 
&• CENTS 
C 

1002  FORMAT 
C 

1035  FORMAT 
C 


<///?4X"AVERAGE  COST  TO  EXCAVATE  SPOIL 
PER  CUBIC  YARD') 

</?lX?73  (•=•)) 

(IX'ENTER  C TO  CONTINUE?  X TO  EXIT  -> 


♦ 9 

♦ 


F13»2? 


IX 


• ) 


1036  FORMAT  (lAl) 
C 


1040  FORMAT  <1H1?3/?25X' 


•DRAGLINE/OPENING  CUT "3/? 


&5X" HEIGHT  OF  THE 
&5X" AVERAGE  SLOPE 
S5X* LENGTH  OF  THE 
g5X*GENERAL  SLOPE 


SPOIL 
OF  THE 
SPOIL 
OF  THE 


&5X"C0ST  OF  GRADING 
Ji'CENTS/CU*  YD*  ) 


BANK  IS 
SPOIL  IS 
BANK  IS 
AREA  IS 
OVERBURDEN  IS 


•F10*2* 

•F10*2" 

■F10*2* 


: "F10»2 


: *F10.2?1X 


FEET*//? 

DEGREES*//? 

YARDS*//? 

DEGREES*//? 


C 


1050  FORMAT  (1H1?//?25X* DRAGLINE/MINE  RUN *///? 

& lOX'DIST*  BETWEEN  SPOIL  BANK  PEAKS  lSfF10*2?lX 
&'FEET*//? 


& lOX'INITIAL  SLOPE  OF  THE  SPOIL  IB 
^'DEGREES*//? 

X lOX* TOTAL  AREA  COVERED  BY  SPOILS  IS 
S' ACRES*// 

S lOX* GENERAL  SLOPE  OF  THE  AREA  IS 
S'DEGREES*// 

S lOX'COST  OF  GRADING  OVERBURDEN  IS 
>■ CENTS  / CU*  YD*) 


: *F10.2?1X 
J*F10*2?1X 
: *F10*2? IX 
; *F10*2?1X 


C 

1060  FORMAT  <1H1?//?25X* DRAGLINE/FINAL  CUT *///? 

S lOX'WIDTH  OF  BOTTOM  OF  THE  PIT  ;*F10*2?1X 

S*FEET*//? 

S lOX'TOTAL  LENGTH  OF  THE  PIT  :*F10*2?1X 

S* YARDS*//? 

S 10X*HEIGHT  OF  THE  HIGHWALL  :*F10*2?1X 


S*FEET*//? 


S 10X*HEIGHT  OF  THE  SPOIL  BANK  ;*F10*2?1X 
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0447 

0448 

0449 

0450 

0451 

0452 

0453 

0454 

0455 

0456 

0457 

0458 

0459 

0460 

0461 

0462 

0463 

0464 

0465 

0466 

0467 

0468 

0469 

0470 

0471 

0472 

0473 

0474 

0475 

0476 

0477 

0478 

0479 

0480 

0481 

0482 

0483 

0484 

0485 

0486 

0487 

0488 

0489 

0490 

0491 

0492 

0493 

0494 

0495 

0496 

0497 

0498 

0499 

0500 

0501 

0502 


fFEETW/f 

& lOX'SLOPE  OF  THE  HIGHWALL  J"F10*2>1X 

DEGREES '//y 

& 10X"SL0PE  OF  THE  SPOIL  BANK  t"F10*2»lX 
DEGREES •//» 

& lOX'COST  OF  GRADING  OVERBURDEN  :“F10*2»1X 
&"CENTS  PER  CUBIC  YARD*) 

C 

62  FORMAT  <1H1) 

C 

C 

66  FORMAT  (/>2X>4A2) 

C 

68  FORMAT  ( 16X,F6»2, IX'/" IXy F5*2) 

C 

77  FORMAT  TRUCK  S SHOVEL  MINE  X 

^clX'NO*  "4X'HIGHWALL  SLOPE ' 2X ' HIGHWALL  HEIGHT'2X 
)|:'BENCH  WIDTH ' 2X ' BENCH  LENGTH') 

C 

79  FORMAT  ( 1X*)K' I2f  3X')K'F10*2>3  ( 5X ' )fc  • FIO  ♦ 2 ) / ) 

C 

80  FORMAT  (7^66  (*-')>/» 

COST  OF  GRADING  OVERBURDEN  t*F1042,lX 

)|c'CENTS/CUBlC  YARD'/j 

t2X'tt  AREA  COVERED  BY  UNGRADED  SPOILS  :'F10»2>1X 
5|:*  ACRES'/y 

^2X*tt  REHANDLE  VOLUME  J*F10*2ylX 

:f:'CUBIC  YARDS'/y 

t2X'tt  REHANDLE  COST  :'F10*2ylX 

)»c*  CENTS/CUBIC  YARD* /y  66  (*-')y/) 

C 

82  FORMAT  ( IX ' NO ♦ ' 4X * FINAL  HIGHWALL  SLOPE  * 2X * FINAL  TERRACE  WIDTH*/) 
C 

86  FORMAT  < IX * :<( * I2y  6X * )(« * FIO ♦ 2 y 7X * )«c* FIO *2 ) 

C 

1100  FORMAT  (/ylOX'COST  TO  REMOVE  TOPSOIL  :*F10*2ylX 
&*CENTS  PER  CUBIC  YARD*/y 

5 lOX'COST  TO  RESPREAD  TOPSOIL  :*F10*2ylX 
&*CENTS  PER  CUBIC  YARD*/y 

6 lOX'THICKNESS  OF  TOPSOIL  J*F10»2ylX 

^'INCHES* ) 

C 

1015  FORMAT  (4XyA2yl2A2) 

C 

1120  FORMAT  < 2/ y 30X * OVERBURDEN  X LITHOLOGIC  UNIT  =1*12) 

C 

1130  FORMAT  </y4X*  lU)  THICKNESS  OF  THIS  UNIT  :*F10*2*  FEET* 

&/) 

C 

1125  FORMAT  < / y lOX * AVERAGE  OVERBURDEN  RESPONSES*/) 

C 

1900  FORMATdX* GENERAL  DESCRIPTION  NOT  ENTERED *) 

2000  FORMAT (IX* END  OF  GENERAL  DESCRIPTION  RESPONSES *) 

2001  FORMATdX* END  OF  ENVIRONMENTAL  BATA  ENTRIES *) 

2010  FORMAT (/24X* CURRENT  SLOPE-PERCENT  PAIRS*/ 
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0503 

0504 

0505 

0506 

0507 

0508 

0509 


> 5<3X,4A2f 4X)/ 

> 5 (IX •SLOPE-PERCENT "IX)/ 

> 5<1X- *1X)/) 

2011  F0R«AT(74A1) 

2012  F0RMAT(74< •=• ) ) 

END 


ENIi$ 


&DCDS2  T=00004  IS  ON  CR00015  USING  00053  BLKS  R=0000 


0001  FTN4 


0002  C = = = = = = = = = SUBROUTINE  DCDS2 

0003  C = 

0004  C = niSPLAY  CURRENT  DATA  SET  - SEGMENT  TWO 

0005  C = 


0006  C = SOURCE  FILE  I &DCDS2  OBJECT  FILE  : %DCDS2 

0008  C 

0009  C 

0010  c description: 

0011  c 

0012  C DCDS2  DISPLAYS  THE  RESPONSES  TO  CATEGORIES  6-10* 

0013  C DCDS2  IS  SCHEDULED  THROUGH  CLAIM  SWAP  CONTROL  VIA  PROGRAM  DCDSO 

0014  C 

0015  C CALLING  SEQUENCE: 

0016  C 

0017  C CALL  DCDS2 

0018  C 

0019  c arguments: 

0020  C 

0021  C NONE 

0022  C 

0023  C ACCESSED  BY: 

0024  C 

0025  C CLAIM 

0026  C RCLAM  (SEAMPLAN) 

0027  C 

0028  C SUBROUTINES  SCHEDULED: 

0029  C 

0030  C ERASE  <TCS) 

0031  C HOME  (TCS) 

0032  C OTSPL  (SYS) 

0033  C 

0034  C LOCAL  VARIABLES: 

0035  C 

0036  C SAME  AS  FOR  DCDSl 

0037  C 

0038  C 

0039  C author:  ORVILLE  D«  GREEN 

0040  C 

0041  C CLAIM  RELEASE  1^0  - APRIL  1?  1980 

0042  C 


0043  C 

0044  C 

0045  C 

0046  C 

0047 

0048  C 

0049  C 

0050  C 

0051  C 

0052 

0053  C 

0054  C 


SUBROUTINE  DCDS2 


TEKTRONIX  COMMON 
COMMON  ITEK  (45) 

LOGICAL  UNITS  AND  COMMON  LOCATION 
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COMMON  I ARRY  < 5 ) > I ARY2  ( 5 ) y LE!R  y LUF  j LUL 


0055  C 


0056 

0057 

0058 

0059 


0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 
0081 
0082 

0083 

0084 

0085 

0086 

0087 

0088 

0089 

0090 

0091 


C 

C 

C 


POINTERS 


0060 

COMMON 

EXIT 

?IANM<3) 

?ICLI(2) 

?IGEN(3) 

? IGRU 

0061 

COMMON 

lOPTN 

? I0VR(7) 

? IPNTR 

?IS0C(6) 

?ISUB 

0062 

COMMON 

ISURC6) 

? I TOP (9) 

? IVEG(2) 

?LEXIT 

?LUO 

0063 

COMMON 

MODE 

?NANM 

?NCLI 

?N6EN 

?NGRW 

0064 

COMMON 

NOVR 

?NSECTS 

?NSOC 

?NSUB 

?NSUR 

0065 

COMMON 

NTOP 

?NU 

?NVEG 

C 

C 

C 


C 

C 

C 


C 

C 

C 


C 

C 

C 


C 

C 


GRADING  PARAMETERS 

COMMON  AREA<5) , DENLEN ( 5 y 10 ) yBENWI(5»10) j COGO^ GCPA < 5 ) 
COMMON  GRDMBS(5) tHWHT (5> 10) ? HWSLI(5y 10) tNSPP(5) y PCEQ19(4) 
COMMON  PERCNT(5» 10) »REHCPY<5) j REHMOL ( 5 ) y SLOPE ( 5 » 10 ) jWBP 

CATEGORY  TEXT 

COMMON  ANIM<23> 13) yCLMA( 13? 13) »GDES( 15y 13) ?GWHY<22y 13) 
COMMON  0VBD<11?13)?SBSL(13)?  SCEC < 33 ? 13 ) ? SWHY ( 44 ? 13 ) 
COMMON  TPSL<49?13) ?UGTA<15?13) 

EXPECTATION  VALUES 

COMMON  ANIMAL(13?6) ?CLIMAT<8?6) ?GENDES(8?6) jGRUHYD<19? 
COMMON  0VRBDN(28?6) ?S0CECN(29?6) ?SLIBS0I(30?6) ?SURHYD(2 
COMMON  TOPSOl <33?6) »VEGETA(10?6) 

CATEGORY  RESPONSES 


■^)  ?RCLIMA(2)  jRGENDE(3)  ?RGRUHY(5) 


COMMON  RANIMA< 

COMMON  R0VRBD<7?10) ?RS0CEC<6) ? RSUBSO ( 8 ) ? RSURHY< 6 ) 
COMMON  RT0PS0(9) ?RVE6ET <2) 

feasijTeconjOPUse  subsystem  parameters 


0092  C 

0093 

0094 

0095 

0096 

0097 

0098 

0099  C 

0100 
Old 
0102 

0103 

0104 

0105 

0106 

0107 

0108  C 

0109 

0110 


COMMON  CAAHM  ? CABAH  ? CABF  N < 3 ) ? CABFP  < 3 ) ? C ABHM 

COMMON  CABS  < 2 ) ? CAC  ? CACP  ? CADF  ? CADH 

COMMON  CADS  ? CAEAF  ? CAHSAF  ? CAHSTS  ? CAI P 

COMMON  CAR3FC  ? CASF  ? CASNC  ? CSTES  ? CSTRM 

COMMON  CSTRP  ? FAV6  < 5 ) ? PFSTSP  ? PFAC  ? RCLTEC ( 29  ? 34 ) 

COMMON  TCAR(5) ? THICK (10) ? THKTS ? TTL < 40 ) 


INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 


EXIT?  CLMA  ? 6DES  ? GWH Y ? OVBD  ? SBSL 
SCEC  ? SWH Y ? TPSL  ? V6TA  ? ANIM 
CL I MAT  ? GENDES  ? 6RWHYD  ? OVRBDN 
SOCECN  ? SUBSO I ? SURHYD  ? TOPSOI 
VEGETA? ANIMAL 

RCL I MA  ? RGENDE  ? RGRWH Y ? ROVRBD  ? RSOCEC 
RSUBSO  ? RSURH Y ? RTOPSO  ? RVEGET  ? RANIMA 
RCLTEC ?TTL 


INTEGER  COMMON  (1) 

EQUIVALENCE  (COMMON  (1)?  ITEK  <D) 
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w o 


0111 

0112 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120 

0121 

0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 

0161 

0162 

0163 

0164 

0165 

0166 


C 

C 

C 


EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

LOGICAL  LER 


(lARRY 

(IARY2 

(1ARY2 

(IARY2 

(IARY2 


(1)  y 
<1)  y 
<2)  y 
<3)  y 
<4)  y 


LUT) 

ISTRK) 

ISECT) 

ICODE) 

LEN) 


INTEGER  CHNG<8) 

INTEGER  START6(5) ySIART7<2) ySTART0(4) 
INTEGER  ST0P6(5) yST0P7(2) yST0P0(4) 


C 

C 

C 


DATA  START6/lly25y29y33y39/ 
DATA  START7/33y39/ 

DATA  START0/17y24y27y30/ 
DATA  ST0P6/19y25y29y34y 40/ 
DATA  ST0P7/34y40/ 

DATA  ST0P0/17y26y29y 33/ 

DATA  CHN6/2H  Ay2H  By2H  Cy2H 

SPOOL  OUTPUT 

IF  (LUL  .EQ*  LUT)  GOTO  1 
CALL  OTSPL  <LUy  1) 

IF  <LU  ♦LT*  0)  GOTO  5000 


Dy2H  Ey2H  F y 2H  Gy2H  H/ 


C 

C 


C 

C 

C 


LUL 


LU 


OR*  LUL  *NE*  LUT)  GOTO  210 


IF  (*NOT«  LER 
CALL  ERASE 
CALL  HOME 
KPASS=0 


SURFACE  WATER  HYDROLOGY  CATEGORY 


210  IF(RSURHY<1) *EQ*0)  GOTO  5 
WRITE  (LULylOOO)  TTL 
WRITE  (LULylOOl) 

WRITE  (LULylOlO)  ( (SWHY 
IF  <RSURHY  (1)  *NE*  1) 


000 


<KyI)yI=lyl3)yK=ly5) 


WRITE 

WRITE 


(LULylOlO) 
(LULy 1020) 


(SWHY 


214 


GOTO  215 
WRITE  (LULyl020) 


GOTO  214 
(6yl)yl=lyl3) 

(SWHY  (7yl)yl=lyl3)y 
(SURHYD  (ly I) y I=ly6) 

(SWHY  (RSURHY  ( 1 ) +6 y I ) y 1=1 y 13 ) y 
(SURHYD  (RSURHY  ( 1 ) y I ) y 1=1 y 6 ) 


215 


Am  Am  JL 


0 


IPLACE 
DO  225  JJ=2yNSUR 
IF ( RSURHY (JJ) *Ea*0) 


GOTO  5000 


WRITE (LULy 1010) ( (SWHY(Ky 1 ) y I 
WRITE  III  rQ 


IF 

IF 


(LULy 1020)  (SWHY  (RSURHY 
(SURHYD  (RSURHY 
*EQ*  LU)  GOTO  225 


1 y 1 3 ) y K=START6 ( J J- 1 ) y ST0P6 ( J J- 1 ) ) 
( JJ)-fST0P6(JJ~l)  y I)  y I = ly  13)  y 
( JJ)+IPLACEy I ) y 1=1 y6) 


(LUL 
(JJ  *EQ*  2 


♦OR*  JJ  *EQ*  4)  224 y 225 
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0167 

0168 

0169 

0170 

0171 

0172 

0173 

0174 

0175 

0176 

0177 

0178 

0179 

0180 
0181 
0182 

0183 

0184 

0185 

0186 

0187 

0188 

0189 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

0197 

0198 

0199 

0200 
0201 
0202 

0203 

0204 

0205 

0206 

0207 

0208 

0209 

0210 
0211 
0212 

0213 

0214 

0215 

0216 

0217 

0218 

0219 

0220 
0221 
0222 


224  WRITE  (LUT»  1002) 

WRITE  <LUTr  1035) 

READ  (LUTf  1036)  IANS 

IF  (IANS  *EQ*  IHX)  GOTO  5000 
IF  (LER)  CALL  ERASE 
IF  (LER)  CALL  HONE 
WRITE  (LUTt  1000)  TTL 
WRITE  (LUTj  1001) 

WRITE  (LUfy  1010)  ((SWMY(I» J)»J=1?13),I=1j2) 

225  IPLACE  = IPLACE  + ISUR  (JJ) 

WRITE  (LUL>1002) 

IF  (LUL  *EQ*  LU)  GOTO  230 
WRITE  (LUr>1035) 

READ  (LUTj1036)  IANS 
IF  (IANS  .EQ*  IHX)  GOTO  5000 
IF  (LER)  CALL  ERASE 
IF  (LER)  CALL  HOME 
C 

C GROUND  WATER  HYDROLOGY  CATEGORY 

C 

230  IF(RGRWHYd)  *EQ*0)  GOTO  5000 
WRITE  (LULdOOO)  TTL 
WRITE  (LULdOOl) 

WRITE  (LULrlOlO)  ( (GWHY  (Kd ) » 1=1 >13) ? K=1 y 5) 

WRITE  (LUL>1020)  (GWHY  (RGRWHY  ( 1 ) +5 d ) > 1=1 > 13 ) > 

& (GRWHYD  (RGRWHY  ( 1 ) > 1 ) > 1=1 > 6 ) 

IF(RGRWHY(2) .EQ*0)  GOTO  5000 

WRITE  (LULjIOIO)  ( (GWHY  (K> 1 ) > 1=1 > 13) >K=10> 18) 

WRITE  (LUL>1020)  (SWHY  (RGRWHY  (2)+19> I ) > 1=1 > 13) > 

I (GRWHYD  (RGRWHY  (2)+IGRW  ( 1 ) > I ) > 1=1 » 6 ) 

IPLACE  = 0 

IF  (LUL<EQ<LUT)  WRITE  (LUT>1002) 

IF  (LUL*EQ*LUT)  WRITE  (LUT>1035) 

IF  (LUL*EQ*LUT)  READ  (LUT>1036)  IANS 

IF  (IANS  *EQ*  IHX)  GOTO  5000 

IF  (LER)  CALL  ERASE 

IF  (LER)  CALL  HOME 

WRITE  (LUL >1000)  TTL 

WRITE  (LUL>1001) 

DO  235  JJ=3>4 

IF(RGRWHY( JJ) .EQ.O)  GOTO  5000 

233  WRITE  (LUL>1015)  CHNG  (JJ)>  (SWHY  (START7( JJ-2) > I ) > I=3> 13) 
WRITE(LUL>1010) ( (SWHY(K>I) >I=1>13) >K=START7( JJ-2)-M>ST0P7( JJ 
WRITE  (LUL>1020)  (SWHY  (RGRWHY  ( JJ)+ST0P7( JJ-2) > 1 ) > 1=1 > 13) > 

& (GRWHYD  (RGRWHY  ( JJ)+IPLACE > I ) > 1=1 > 6 ) 

IF  (LUL  *EQ.  LU)  GOTO  235 
IF  (JJ  .EO*  2)  234>  235 

234  WRITE  (LUT>  1002) 

WRITE  (LUT>  1035) 

READ  (LUT>  1036)  IANS 

IF  (IANS  .EQ.  IHX)  GOTO  5000 
IF  (LER)  CALL  ERASE 
IF  (LER)  CALL  HOME 
WRITE  (LUT>  1000)  TTL 
WRITE  (LUr>  1001) 

WRITE  (LUf>  1010)  ((GWHY  (1>J)>  J = 1>  13)>  1 = 1>2) 


0223 

0224 

0225 

0226 

0227 

0228 

0229 

0230 

0231 

0232 

0233 

0234 

0235 

0236 

0237 

0238 

0239 

0240 

0241 

0242 

0243 

0244 

0245 

0246 

0247 

0248 

0249 

0250 

0251 

0252 

0253 

0254 

0255 

0256 

0257 

0258 

0259 

0260 

0261 

0262 

0263 

0264 

0265 

0266 

0267 

0268 

0269 

0270 

0271 

0272 

0273 

0274 

0275 

0276 

0277 

0278 


235  IPLACE  = IPLACE  + IGRU  <JJ) 

WRITE  (LULylOlO)  < <GWHY  (K» 1 ) » 1=1 , 13) »K=19,20) 

WRITE  <LULyi020)  <GWHY  (RGRWHY  (5)+20r I ) , 1=1 ? 13) » 

& (GRWHYD  (RGRWHY  ( 5 ) +IPLACE , I ) t 1=1 j 6 ) 

WRITE  (LUL>1002) 

IF  (LUL  *EQ*  LU)  GOTO  240 
WRITE  (LOT, 1035) 

READ  ( LOT j 1036)  IANS 
IF  (IANS  *EQ»  IHX)  GOTO  5000 
IF  (LER)  CALL  ERASE 
IF  (LER)  CALL  HOME 
C 

C VEGETATION  CATEGORY 

C 

240  WRITE  (LULflOOO)  TTL 
IPLACE  = 0 

WRITE  (LULjIOOI) 

WRITE  (LULjIOIO)  (VGTA  ( 1 j I ) y 1 = 1 y 13 ) 

DO  249  IR  = ly  2 
IF (RVEGET(IR) *EQ*0)  GOTO  5000 

IF  (IR  .EQ.  1)  WRITE  (LULjIOIO)  ( (VGTA  ( K y 1 ) y 1=1 y 13 ) y K=2 y 3 ) 
IF  (IR  «EQ.  2)  WRITE  (LULylOlO)  (VGTA  ( 14 y I ) y 1=1 y 13) 

GOTO  (241y242y243y244y247)  RVEGET  (IR) 

241  ISTART  = 4 
GOTO  245 

242  ISTART  = 6 
GOTO  245 

243  ISTART  = 6 
GOTO  246 

244  ISTART  = 6 
GOTO  246 

247  IF  (IR  *EQ«  2)  GOTO  248 
ISTART  =11 

GOTO  245 

248  ISTART  =10 
GOTO  246 

245  WRITE  (LULylOlO)  (VGTA  ( ISTART y I ) y 1=1 y 13) 

IF  (RVEGET  (IR)  ♦EQ.  1)  GOTO  246 

WRITE  (LULylOlO)  (VGTA  ( ISTARTTl y 1 ) y 1=1 y 1 3 ) 

246  WRITE  (LULyl020)  (VGTA  (RVEGET  ( 1R)+ISTART y I ) y 1=1 y 13) y 

S (VEGETA  (RVEGET  ( IR)+IPLACEy I ) y 1=1 y 6) 

IPLACE  = IVEG  (IR) 

249  CONTINUE 

WRITE  ( LUL y 1002) 

IF  (LUL  <EQ*  LU)  GOTO  250 
WRITE  (LUTyl035) 

READ  (LUTyl036)  IANS 
IF  (IANS  ♦ECU  IHX)  GOTO  5000 
IF  (LER)  CALL  ERASE 
IF  (LER)  CALL  HONE 
C 

C ANIHALS  CATEGORY 

C 

250  1F(RANIMA(1 ) ♦EQ*0)  GOTO  5000 
WRITE  (LULylOOO)  TTL 

WRITE  (LULylOOl) 


78 


0279 

0280 

0281 

0282 

0283 

0284 

0285 

0286 

0287 

0288 

0289 

0290 

0291 

0292 

0293 

0294 

0295 

0296 

0297 

0298 

0299 

0300 

0301 

0302 

0303 

0304 

0305 

0306 

0307 

0308 

0309 

0310 

0311 

0312 

0313 

0314 

0315 

0316 

0317 

0318 

0319 

0320 

0321 

0322 

0323 

0324 

0325 

0326 

0327 

0328 

0329 

0330 

0331 

0332 

0333 

0334 


WRITE  (LUL^IOIO)  < (ANIM  < K , I ) ? 1=1 j 13 ) , K=1 , 3 ) 

ISTART  = 2 + 2 RANIMA  <1) 

IF  (RANIMA  (1)  5)  ISTART  = ISTART  + 2 

ISTOP  = ISTART  +1 

IF  (RANIMA  (1)  *EQ«  4)  ISTOP  = ISTOP  + 3 
IPLACE  = 0 

WRITE  (LULjIOIO)  < (ANIM  <K> I ) j 1=1 j 13) ?K=ISTART j ISTOP-1 ) 
WRITE  <LULfl020)  (ANIM  ( ISTOP r I ) » 1=1 » 13 ) ? 

& (ANIMAL  (RANIMA  ( 1 ) +IPLACE » I ) y 1=1 > 6 ) 

WRITE  (LULtIOIO)  (ANIM  ( 1 t I ) j 1 = 1 y 13 ) 

WRITE  (LULjIOIO)  ( (ANIM  ( K j 1 ) > 1=1 » 13 ) > K=20 j 21 ) 

IF(RANIMA(2) .E0*0)  GOTO  5000 
ISTART  = 2 + 2 )fc  RANIMA  (2) 

ISTOP  = ISTART  + 1 

IF  (RANIMA  (2)  *EQ*  4)  ISTOP  = ISTOP  + 3 
IF  (RANIMA  (2)  .EQ*  5)  ISTART  = 22 
IF  (RANIMA  (2)  *EQ*  5)  ISTOP  = 23 
IPLACE  = IPLACE  + lANM  (1) 

WRITE  (LUL^IOIO)  ( (ANIM  (Ky 1) y 1=1 y 13) y K=ISTART, ISTOP-1 ) 
WRITE  (LULyl020)  (ANIM  ( ISTOP y I ) y 1=1 y 1 3 ) y 
t (ANIMAL  (RANIMA  (2)+IPLACEy I ) y 1=1 y 6) 

WRITE  (LULylOlO)  ( (ANIM  ( K y I ) y 1= 1 y 1 3 ) y K= 1 6 y 1 7 ) 

1F(RANIMA(3)  c-EQ*0)  GOTO  5000 
IPLACE=  IPLACE  + lANM  (1)  +IANM  (2) 

WRITE  (LULyl020)  (ANIM  (RANIMA  (3)+17y I ) y 1=1 y 13) y 

5 (ANIMAL  (RANIMA  (3)+lPLACEy I ) y 1=1 y 6) 

WRITE  (LULyl002) 

IF  (LUL  *EQ*  LU)  GOTO  270 
WRITE  (LUTyl035) 

READ  (LUTyl036)  IANS 
IF  (IANS  *EQ»  IHX)  GOTO  5000 
IF  (LER)  CALL  ERASE 
IF  (LER)  CALL  HOME 
C 

C SOCIO-ECONOMICS  CATEGORY 

C 

270  IF(RSOCECd)  .EQ.O)  GOTO  5000 
WRITE  (LULylOOO)  TTL 
WRITE  (LULylOOl) 

WRITE  (LULylOlO)  ( (SCEC  (Ky I ) y 1=1 y 13) y K=1 y 4 ) 

IPLACE  = 0 

WRITE  (LULyl020)  ( SCEC  (RSOCEC  (l)+4  yl)yl=lyl3)y 

6 (SOCECN  (RSOCEC  ( 1 ) +1PLACE y I ) y 1=1 y 6 ) 

WRITE  (LULylOlO)  ( (SCEC  ( K y 1 ) y 1=1 y 13 ) y K=7 y 8 ) 

IPLACE  = IPLACE  + ISOC  (1) 

LL=9 

IF  (RSOCEC  (2)*GE.5)  LL=10 
ISTART  = ISTOP 

IF  (RSOCEC  (2)  *EQ^  1 ♦OR*  RSOCEC  (2)  *EQ*  5)  ISTOP  = ISTART  - 
IF  (ISTART  ♦EQ*  ISTOP)  GOTO  275 

WRITE  (LULylOlO)  (SCEC  (RSOCEC  ( 2 ) +LL-1 y I ) y 1=1 y 13 ) 

275  WRITE  (LULyl020)  (SCEC  (RSOCEC  ( 2 ) +LL y I ) y 1=1 y 13 ) y 

S (SOCECN  (RSOCEC  ( 2 ) +IPLACE y I ) y 1=1 y 6 ) 

IPLACE  = 0 
DO  310  JJ=3yNS0C 

WRITE(LULy 1010) ( (SCEC(Ky I) y I=ly 13) yK=STARTO( JJ-2) yST0P0( JJ-2) 
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033ti; 

0336 

0337 

0338 

0339 

0340 

0341 

0342 

0343 

0344 

0345 

0346 

0347 

0348 

0349 

0350 

0351 

0352 

0353 

0354 

0355 

0356 

0357 

0358 

0359 

0360 

0361 

0362 

0363 

0364 

0365 

0366 

0367 

0368 

0369 

0370 

0371 

0372 

0373 

0374 

0375 

0376 

0377 

0378 

0379 

0380 

0381 

0382 

0383 

0384 

0385 

0386 

0387 

0388 

0389 

0390 


WRITE  (LULj1020)  <SCEC  (R80CEC  ( JJ) +17 » I ) » 1=1 , 13 ) > 

& (SOCECN  (RSOCEC  ( JJ ) +IPLACE > 1 ) j 1=1 , 6 ) 

IF  <LUL  ♦EQ*  LU)  GOTO  310 
IF  <JJ  *EQ»  3)  ZOBf  310 
308  WRITE  (LUTt  1002) 

WRITE  <LUT>  1035) 

READ  <LUT»  1036)  IANS 
IF  (IANS  *EQt  IHX)  GOTO  5000 
IF  (LER)  CALL  ERASE 
IF  (LER)  CALL  HOHE 
WRITE  (LUT,  1000)  TTL 
WRITE  (LUTy  1001) 

WRITE  (LUTj  1010)  (SCEC  (1>J)»J  = 1>  13) 

310  IPLACE  = IPLACE  + ISOC  (JJ) 

WRITE  (LULyl002) 

IF  (LUL  .-EQ*  LU)  GOTO  350 
WRITE  (LUT j 1035) 

READ  (LUTj1036)  IANS 
IF  (IANS  ♦EQ*  IHX)  GOTO  5000 
IF  (LER)  CALL  ERASE 
IF  (LER)  CALL  HOHE 
350  CONTINUE 
KPASS=1 

5000  1F(KPASS<EQ.0*AND.IANS*NE*1HX)  WRlTE(LUTr 2000) 

IF  (LUL  ♦EQ*  LUT)  GOTO  5001 

CALL  OTSPL  (LUy2) 

RETURN 

5001  1F(KPASS*EQ*0*AND* IANS«NE*1HX)  CALL  BELL 
IF(KPASS»Ea*0»AND«IANS*NE*lHX)  CALL  TINPT(ICHAR) 

RETURN 

C 

C FORHAT  STATEHENTS 

C 

1000  FORMAT  (IHlj 
S1X>40A2»/ 

LIST  OF  RESPONSES  TO  ENVIRONMENTAL  “ IX 
^'FEASIBILITY  CATEGORIES  ttf) 

C 


1001  FORMAT  ( /jIOX'  RESPONSE  ' 12X ' EXPECTATION ' IX 

&“0F  SUCCESS  VALUES'/? 

S lOX' '12X' 'IX 

J;. V, 

>32X • /CRDP/NAT . /WILD/WAT ♦ /HIGH/OTHER/ ' / ? 

>32X ' /LAND/VEG ♦ /L IFE/REC ♦ /USE  / / ' / 

>1X?73  ('=')//) 

C 

1010  FORMAT  (4X?13A2) 

C 

1020  FORMAT  ( IX ' ' IX ? 13A2 ? 5X ? 1 1 ? 5 (4X>11)/) 


1002  FORMAT  (/?1X?73  (“=')) 
C 


1035  FORMAT  (/?1X'ENTER  C TO  CONTINUE?  X TO  EXIT  ->  «. ' ) 
C 

1036  FORMAT  (lAl) 

C 
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0391  C 

0392  1015  FORMAT  <4X>A2?12A2) 

0393  C 

0394  2000  F0RMAT(1X“ END  OF  ENVIRONMENTAL  DATA  ENTRIES “) 

0395  END 

0396  END$ 
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0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 

0011 

0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 

0021 

0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 

0053 

0054 


1=00004  IS  ON  CR00015  USING  00026  BLKS  R=0000 


FTN4 


C = = = = SUBROUTINE  DCEO  = = = = 

c = 

C = DISPLAY  THE  CURRENT  EXPECTATION  VALUES 

C = 


C = SOURCE  FILE  t &DCEV  OBJECT  FILE  : %DCEV 

C = = ===:===:==  = ===:====  = ===t=====:===:======  = = ==  = = = ==  = ===============:=:=:===========:===:  = =:  = ==  = =====:  = =====:=:=====:=: 

c 

c 

c description: 
c 

C DCEV  DISPLAYS  THE  CURRENT  EXPECTATION  OF  SUCCESS  VALUES  ON  THE 

C LINE  PRINTER c-  OUTPUT  IS  SPOOLED 

C DCEV  IS  SCHEDULED  THROUGH  CLAIM  SWAP  CONTROL  VIA  PROGRAM  DCEVX 

C 

C CALLING  sequence: 

C 

C CALL  DCEV 

C 

c arguments:  none 

c 

C ACCESSED  by: 

c 

C CLAIM 

C RCLAM  (SEAMPLAN) 

C 

C SUBROUTINES  SCHEDULED: 

C 

C OTSPL  (SYS) 

C 

C LOCAL  variables:  NONE 

C 

C 

C author:  STEVEN  A*  EASTMAN 

C 

C CLAIM  RELEASE  1*0  - APRIL  ly  1980 

C 

C 

C =:  = =:====  = = =======:  = ===:==============================  = =================.=======::===:  = ===========:  = ===========:========  = ^ 

c 


c 


SUBROUTINE  DCEV 


C 

C 

C 

C 

C 

C 

C 

C 

C 

C 


TEKTRONIX  COMMON 
COMMON  ITEK  (45) 

LOGICAL  UNITS  AND  COMMON  LOCATION 
COMMON  1ARRY(5) y IARY2(5) >LER»LUF»LU 
POINTERS 
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0055 

0056 

0057 

0058 

0059 

0060 

0061  C 

0062  C 

0063  C 

0064 

0065 

0066 

0067  C 

0068  C 

0069  C 

0070 

0071 

0072 

0073  C 

0074  C 

0075  C 

0076 

0077 

0078 

0079  C 

0080  C 

0081  C 

0082 

0083 

0084 

0085  C 

0086  C 

0087  C 

0088 

0089 

0090 

0091 

0092 

0093 

0094  C 

0095 

0096 

0097 

0098 

0099 

0100 
0101 
0102 

0103  C 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


COMMON  EXIT  » I ANM < 3 ) » ICLI (2 ) » I6EN ( 3 ) ^ I6RW ( 5 ) 

COMMON  lOPTN  » lOOR ( 7 ) , IPNTR  , ISOC < 6 ) » ISUB ( 8 ) 

COMMON  ISUR(6) j IT0P(9) >I0E6(2) jLEXIT  >LU0 
COMMON  MODE  yNANM  »NCLI  jNGEN  »N6RW 

COMMON  NOOR  >NSECTS  jNSOC  >NSUB  jNSUR 

COMMON  NTOP  >NU  ,NOEG 

GRADING  PARAMETERS 

COMMON  AREA<5) ?BENLEN(5»10) jBENWI(5y 10) jC0G0»6CPA(5) 

COMMON  GRDMBS ( 5 ) » HWHT  < 5 ? 1 0 ) y HU SL I < 5 j 1 0 ) y NSPP  < 5 ) y PCEQ 1 9 < 4 ) 
COMMON  PERCNT ( 5 y 1 0 ) y REHCPY  < 5 ) y REHVOL  < 5 ) y SLOPE  < 5 y 1 0 ) y WBP 

CATEGORY  TEXT 

COMMON  ANIM(23y 13) yCLMA(13y 13) yGDES( 15y 13) y GWHY(22y 13) 
COMMON  0yBD(llyl3)ySBSL<13)y  SCEC ( 33 y 13 ) y SWHY < 44 y 13 ) 

COMMON  TPSL(49y 13) yOGTA(15y 13) 

EXPECTATION  VALUES 

COMMON  ANIMAL(13y6) yCLlMAT<8y6) yGENDES(8y6) yGRWHYD(19y6) 
COMMON  0VRBDN<2Sy 6) yS0CECN(29y6) ySUBS0K30y6) ySURHYD(23y6) 
COMMON  T0PS0I(33y6) y VEGETA<10y6) 

CATEGORY  RESPONSES 

COMMON  RANIMA(3) yRCLlMA(2) y RGENDE<3) y RGRWHY(5) 

COMMON  ROVRBD ( 7 y 1 0 ) y RSOCEC  C 6 ) y RSUBSO ( 8 ) y RSURHY ( 6 ) 

COMMON  RTOPSO ( 9 ) y RVEGET ( 2 ) 

FEASIyTECONyOPUSE  SUBSYSTEM  PARAMETERS 

COMMON  CAAHMyCABAHyCABFN(3) yCABFP(3) yCABHM 

COMMON  CABS  < 2 ) y C AC  y CACP  p CADE  y CADH 

COMMON  CADS  y CAEAF  y CAHSAF  y CAHSTS  y CAIP 

COMMON  CAR3FC  y CASE  y CASNC  y CSTES  y CS7  RM 

COMMON  CST  RP  y FAVG ( 5 ) y PFSTSP  y PFAC  y RCLTEC ( 29  y 34 ) 

COMMON  TCAR(5) y THICK (10) y THKTS y TTL < 40 ) 


INTEGER  EX I T y CLMA  y GDES  y GWHY  y OVBD  y SBSL 
IN  I EGER  SCEC  y SWH Y y TPSL  y VGTA  y ANIM 
INTEGER  CLI MAT  y GENDES  y GRUH YD  y OVRBDN 
INTEGER  SOCECNySUBSOlySURHYDyTOPSOI 
INIEGER  VEGETAyANIMAL 

INTEGER  RCLIMAyRGENDEyRGRWHYyROVRBDyRSOCEC 
INTEGER  RSUBSO  y RSURHY  y RTOPSO  y RUEGET  y RANIMA 
INTEGER  RCLTECyTTL 


INTEGER  COMMON  (1) 


EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 


(COMMON  (l)y 
(lARRY  (l)y 
(IARY2  (l)y 
(1ARY2  (2)y 
(IARY2  (3)y 
(IARY2  (4)y 


ITEK  (1)) 
LU  I ) 

ISTRK) 

ISECT) 

ICODE) 

LEN) 
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0111 

0112 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120 

0121 

0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 

0161 

0162 

0163 

0164 

0165 

0166 


C 


LOGICAL  LER 
DIMENSION  IALPH(15) 


C 

DATA  lALPH  / 2HA  t2HB  > 2HC  >2HD  » 2HE  > 

g 2HF  ,2HG  »2HH  »2HI  »2HJ  » 

g 2HK  j2HL  »2HM  >2HN  j2H0  / 

C 

C 

C SPOOL  OUTPUT 

C 

CALL  OTSPL  (LU>  1) 

IF  (LU  *LT»  0)  STOP  1 
WRITE(LU» 1010) 

1010  F0RMAT(lHl»/y30X» "LIST  OF  EXPECTATIONS  OF  SUCCESS  VALUES"// 
g 2X" SECTION  CATA60RY  SELECTION  CROP  NATIVE  " 

g • WILDLIFE  WATER  REC  HIGH  USE  OTHER  "/) 

C 

C CATAGORY  1 : GENERAL  DESCRIPTION 

C 

K=1 

KKAT  = 1 

DO  10  J=1»N6EN 

WRITE(LU?1030) 

1030  FORMAT(/) 

DO  10  L=1»I6EN(J) 

WRITE  (LU? 1000)  KKAT? IALPH< J) ?L?  < GENDES ( K ? I ) ? 1=1? 6) 

1000  F0RMAT(4X? 12? IIX? A2? lOX? I2?2X?6(9X? 12) ) 

K=K-1-1 

10  CONTINUE 

C CATAGORY  2:  CLIMATOLOGY 

K=1 

KKAT  = 2 
DO  20J=1?NCLI 
WRITE(LU? 1030) 

DO  20  L=1?ICLI(J) 

WRITE  (LU?1000)  KKAT?IALPH( J) ?L?  (CLIMAT(K? I ) ? 1=1 ?6) 

K=K-M 

20  CONTINUE 

C CATAGORY  3 TOPSOIL 

K=1 

KKAT  = 3 
DO  30  J=1?NT0P 
WRITE(LU? 1030) 

DO  30  L=1?IT0P(J) 

WRITE  (LU?1000)  KKAT?IALPH(J)?L?  (TOPSOI  <K?D?  I = l?6) 

K=K+1 

30  CONTINUE 
C CAT  At  SUBSOIL 

K=1 

KKAT  = 4 
DO  40  J=1?NSUB 
WR1TE(LU? 1030) 

DO  40  L=l?  ISUB(J) 

WRITE  (LU? 1000)  KKAT?IALPH( J) ?L?  (SUBSOI (K? I ) ? 1=1 ? 6) 

K=K+1 
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0167 

40 

CONTINUE 

0168 

C 

CAT  5?  OVERBURDEN 

0169 

K=1 

0170 

KKAT  = 5 

0171 

BO  50  J=1»N0VR 

0172 

WRITE(LU, 1030) 

0173 

DO  50  L=1>10VR(J) 

0174 

WRITE  (LLlylOOO)  KKAT  » I ALPH  ( J ) y L y 

(OVRBDN(Ky I) 

y I=ly6) 

0175 

K=KT1 

0176 

50 

CONTINUE 

0177 

C 

CATAGORY  6 t SURFACE  HYDROLOGY 

0178 

K=1 

0179 

KKAT  = 6 

0180 

DO  60  J=lyNSUR 

0181 

WRlTE(LUy 1030) 

0182 

DO  60  L=lylSUR(J) 

0183 

WRITE  (LUylOOO)  KKAT y I ALPH ( J ) y L y 

(SURHYD(Ky I) 

yl=ly6) 

0184 

K=K+1 

0185 

60 

CONTINUE 

0186 

C 

CAT  7 G.W*  HYDROLOGY 

0187 

K=1 

0188 

KKAT  = 7 

0189 

DO  70  J=ly  NGRW 

0190 

WRlTECLUy 1030) 

0191 

DO  70  L=ly  IGRW(J) 

0192 

WRITE  (LUylOOO)  KKATy lALPHC J) yLy 

(GRWHYD(Ky I) 

y I=ly6) 

0193 

K=K+1 

0194 

70 

CONTINUE 

0195 

C 

CAT  8 VEGETATION 

0196 

K=1 

0197 

KKAT  = 8 

0198 

DO  80  J=lyNVEG 

0199 

WRITE(LUy 1030) 

0200 

DO  80  L=ly  IVE6(J) 

0201 

WRITE  (LUylOOO)  KKAT y I ALPH ( J ) y L y 

(VEGETA (Kyi) 

y I=ly6 

0202 

K=KT1 

0203 

80 

CONTINUE 

0204 

C 

CAT  9 WILDLIFE 

0205 

K=1 

0206 

KKAT  = 9 

* 

0207 

DO  90  J=lyNANN 

0208 

WRITE(LUy 1030) 

0209 

DO  90  L=lyIANH(J) 

0210 

WRITE  (LUylOOO)  KKAT y I ALPH ( J ) y L y 

(ANIMAL(Ky I ) 

yl=ly6) 

0211 

K=K-M 

0212 

90 

CONTINUE 

0213 

C 

CAT  10  SOCIO-ECONOMIC  FACTORS 

0214 

K=1 

0215 

KKAT  =10 

0216 

DO  100  J=lyNSOC 

0217 

WRITE(LUy 1030) 

0218 

DO  100  L=lyISOC(J) 

0219 

WRITE  (LUylOOO)  KKATy lALPH(J) yLy 

(SOCECN(Ky I) 

y 1 = 1 y 6 ) 

0220 

K=KT1 

0221 

100 

CONTINUE 

0222 

C 

QUIT  OTSPL 
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I 


0223 

0224 

0225 

0226 

0227  EMD^- 


C 

C 


. CALL  OTSPL  <LU>  2) 
END 
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SUBROUTINE  DLDCS 

DRAGLINE  t DISPLAY  CURRENT  SLOPES  AND  PERCENTS  


C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 


C 

C 

C 

C 

C 

C 

C 

c 

c 

c 

c 

c 

c 

c 


LEVEL  3 

DLDCS  IS  ACCESSED  BY  DLGE  TO  DISPLAY  THE  CURRENI  SLOPE/PERCENT 
PAIRS  FOR  THE  DRAGLINE  MINEr  AND  TO  ALLOW  USER  MODIFICATION 
OR  REDEFINITION  OF  THEM. 

THE  CALLING  SEQUENCE  IS  : CALL  DLDCS 

SUBROUTINES  SCHEDULED  BY  DLDCS  AREt 

FIXSP  TO  FIX  THE  SLOPE/PERCENT  PAIRS 
FIXLN  TO  FIX  THE  LINE  OF  OUTPUT 

DLISP  10  INPUT  USER  DEFINED  SLOPE/PERCENT  PAIRS 
DLDCS  USES  THE  TCS  ROUTINES  I BELL?  ERASE>  HOME,  AND  TINPT 
THE  LOCAL  VARIABLES  ARE! 


IANS  ->  ANSWER  CELL 
KPASS  ->  POINTER 

NUMB  ->  NUMBER  OF  SLOPE/PERCENT  PAIRS  FOR  CURRENT  LUO 

SLOP  ->  SLOPE  ARRAY  FOR  CURRENT  LUO 

PRCT  ~>  PERCENT  ARRAY  FOR  CURRENT  LUO 

LINE  ~>  OUTPUT  LINE 

KPAIR  ->  CURRENT  SLOPE/PERCENT  PAIR 

THIS  ROUTINE  WAS  WRITTEN  BY  GREEN 

CLAIM  RELEASE  1.0  - APRIL  1,  1980 


C 

C TEKTRONIX  COMMON 

C 

COMMON  ITEK  (45) 

C 

C LOGICAL  UNITS  AND  COMMON  LOCATION 

C 

COMMON  IARRY(5) ,IARY2(5) ,LER,LUF,LUL 
C 

C POINTERS 

C 

COMMON  EXIT  , lANM ( 3 ) , ICLl < 2 ) , IGEN ( 3 ) , IGRW < 5 ) 

COMMON  lOPTN  , I0VR<7) , IPNTR  , IS0C(6) , ISUB(8) 


COMMON 

1SUR(6) , IT0P<9) 

,IVE6<2) 

jLEXIT 

,LUO 

COMMON 

MODE  ,MANM 

,NCLI 

yNGEN 

,NGRW 

COMMON 

NOVR  jNSECTS 

,NSOC 

,NGUB 

jNSUR 

p 

COMMON 

NT  OP  ,NU 

,NVEG 

c 

GRADING 

i PARAMETERS 

c 

I 
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0055 

0056 

0057 

0058  C 

0059  C 

0060  C 

0061 
0062 

0063 

0064  C 

0065  C 

0066  C 

0067 

0068 

0069 

0070  C 

0071  C 

0072  C 

0073 

0074 

0075 

0076  C 

0077  C 

0078  C 

0079 

0080 
0081 
0082 

0083 

0084 

0085  C 

0086 

0087 

0088 

0089 

0090 

0091 

0092 


COMMON  AREA  ( 5 ) » BENLEN  ( 5 » 1 0 ) » BENWI  ( 5 » 10 ) y COGO » GCF-’A  ( 5 ) 

COMMON  GRD0BS(5) »HWHT<5y 10) yHWSLI(5y 10) jNSPP(5) >PCEQ19(4) 
COMMON  PERCNI <5y 10) yREHCPY(5) yREH00L(5) y SL0PE(5y 10) y WBP 

CATEGORY  TEXT 

COMMON  ANIM(23y 13) yCLMA(13y 13) yGBES(15y 13) yGWHY(22y 13) 
COMMON  00BB<llyl3)ySBSL(13)y  SCEC(33y 13) y SWHY<44y 13) 

COMMON  TPSL(49yl3)yOGTA<15yl3) 

EXPECTATION  VALUES  . 

COMMON  AN I M AL  < 1 3 y 6 ) y CL 1 MAT ( 8 y 6 ) y 6ENDES ( 8 y 6 ) y GRUH YB  < 1 9 y 6 ) 
COMMON  0VRBDN(28y6) y SOCECN ( 29 y 6 ) y SUBSOI < 30 y 6 ) y SURHYB(23y 6) 
COMMON  TOPSOI (33y6) y VE6ETA(10y6) 

CATEGORY  RESPONSES 

COMMON  RANIMA<3) y RCLIMA ( 2 ) y RGENDE ( 3 ) yRGRUHY(5) 

COMMON  R0VRBD(7y 10) yRS0CEC<6) yRSUBS0<8) yRSURHY(6) 

COMMON  RT0PS0(9) yRVEGET(2) 

FEASIyTECONyOPUSE  SUBSYSTEM  PARAMETERS 

COMMON  CAAHMy CABAHyCABFN(3) yCABFP(3) yCABHM 

COMMON  CABS ( 2 ) y C AC  y CACP  y CADF  y C ADH 

COMMON  CADS  y CAEAF  y CAHSAF  y CAHSTS  y CAI P 

COMMON  CAR3FC  y CASF  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y FAV6  < 5 ) y PFSTSP  y PFAC  y RCLTEC  < 29  y 34 ) 

COMMON  TCAR(5) yTHICK(lO) y THKTS y TTL < 40 ) 


INTEGER  EXI T y CLMA  y GDES  y GWHY  y OVBD  y SBSL 
INTEGER  SCEC  y SUHY  y TPSL  y VGT A y ANI M 
INTEGER  CLIMAT  y GENDES  y GRUHYD  y OVRBDN 
INTEGER  SOCECN y SUBSOI ySURHYDyfOPSOI 
INTEGER  VEGETA y ANIMAL 

I NT  EGER  RCL I MA  y RGENDE  y RGRWHY  y ROVRBD  y RSOCEC 
INTEGER  RSUBSO y RSURH Y? RTOPSO y RVEGET y RANI MA 


0093  INTEGER  RCLTECyTTL 

0094  C 

0095  INTEGER  COMMON  (1) 


0096 

EQUIVALENCE 

(COMMON 

(1) 

y ITEM  CD) 

0097 

EQUIVALENCE 

(lARRY 

(1)  y 

LUT) 

0098 

EQUIVALENCE 

(IARY2 

<l)y 

ISTRK) 

0099 

EQUIVALENCE 

(IARY2 

(2)  y 

I SECT) 

0100 

EQUIVALENCE 

(IARY2 

(3)  y 

ICODE) 

0101 

EQUIVALENCE 

(IARY2 

(4)  y 

LEN) 

0102  C 

0103  LOGICAL  LER 

0104  C 


0105  INTEGER  LINE(74) 

0106  INTEGER  ALTN  (6y4) 

0107  COMMON  /ALTRN/  ALTN 

0108  DIMENSION  PRCT ( 10 ) y SLPE ( 10 ) 

0109  C 

0110  KPASS=0 
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0111 

1 

CALL  FIXSP 

0112 

C 

DISPLAY  THE  CURRENT  SLOPES  AND  PERCENTS 

0113 

LUL  = LUT 

0114 

2 

IF  ( «NOT<  LER  ) GOTO  5 

0115 

CALL  ERASE 

0116 

CALL  HOME 

0117 

5 

1F(LUL*EQ»6)  WRITE(LUL»999) 

0118 

WRITE  (LUL^IOOO)  < ( ALTN < K y J ) > J=1 » 4 ) ? K=1 > 5 ) 

0119 

KPAIR=1 

0120 

6 

CALL  F I XLN ( SLOPE  y PERCNT  y NSPP  y KPAI R y L INE ) 

0121 

URITE(LULy 1010)  LINE 

0122’ 

DO  7 I=ly5 

0123 

IF(NSPP(I) *LE*KPAIR)  GOTO  7 

0124 

KPAIR=KPAIR+1 

0125 

GOTO  6 

0126 

7 

CONTINUE 

0127 

WRITE<LULy 1020) 

0128 

C 

CHECK  POINTER*  IF  NON-ZERO  y WE'RE  DONE 

0129 

IF  (KPASS  *EQ*  0)  GOTO  25 

0130 

IF  <LUL  <EQ*  6 *0R*  *NOT*  LER)  RETURN 

0131 

CALL  DELL 

0132 

CALL  TINPT  (IANS) 

0133 

CALL  ERASE 

0134 

RETURN 

0135 

C 

USER  INPUT  ->  USE  OR  MODIFY  THE  SLOPE/PERCENT  PAIRS 

0136 

25 

WRl TE< LUT y 1040) 

0137 

READ(LUTy)f:)  IANS 

0138 

IF  ( LER)  CALL  ERASE 

0139 

IF  < LER)  CALL  HOME 

0140 

IFdANS  *GE*  1 *AND*  IANS  *LE*  3)  GOTO < 300 y 200 y 100 ) IANS 

0141 

WRITE  <LUTyl050) 

0142 

GOTO  25 

0143 

C 

INPUT  A NEW  SET  OF  SLOPES  AND  PERCENTS 

0144 

100 

ISTART  = 1 

0145 

IQUIT  = 5 

0146 

IF(RGENDE(2) *NE*2)  ISTART  = 2 

0147 

IF  < RGENDE ( 2 ) ♦ EQ  * 2 < AND  * NSPP  < 1 ) ♦ EQ ♦ 0 ) I START=2 

0148 

IF  (RGENDE  (2)  <NE*  2)  IQUIT  = 4 

0149 

DO  110  LUO  = ISTARTy  IQUIT 

0150 

CALL  DLISP  (PRCTySLPEyNUMB) 

0151 

NSPP (LUO)  = NUMB 

0152 

DO  105  J = 1 yNSPP  (LUO) 

0153 

SLOPE (LUOyJ)  = SLPE(J) 

0154 

105 

PERCNT ( LUO yJ)  = PRCT(J) 

0155 

110 

CONTINUE 

0156 

GOTO  290 

0157 

C 

WHICH  LAND  USE  OPTION  NEEDS  MODIFICATION  ? 

0158 

200 

WRITE(LUTy 1060) 

0159 

IF ( RGENDE ( 2 ) < EQ  * 2 ♦ AND  * NSPP ( 1 ) * G T * 0 ) WRI TE ( LUT  y 1 06 1 ) 

0160 

IF ( RGENDE ( 2 ) » NE  * 2 ) WRITE ( LUT  y 1062 ) 

0161 

1 F ( RGENDE ( 2 ) * EQ  * 2 ♦ AND ♦ NSPP ( 1 ) ♦ EQ ♦ 0 ) WRI TE ( LU T y 1063 ) 

0162 

READ  ( LUT  y)^:)  LUO 

0163 

IF  (LUO  *EQ*  0)  GOTO  290 

0164 

IF  (RGENDE  (2)  *EQ*  2)  201 y 202 

0165 

201 

LIMIT=5 

0166 

IF(NSPPd)  *EQ*0)  LIMIT=4 
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0167 

0168 

0169 

0170 

0171 

0172 

0173 

0174 

0175 

0176 

0177 

0178 

0179 

0180 

0181 

0182 

0183 

0184 

0185 

0186 

0187 

0188 

0189 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

0197 

0198 

0199 

0200 

0201 

0202 

0203 

0204 

0205 

0206 

0207 

0208 

0209 

0210 

0211 

0212 

0213 

0214 

0215 

0216 

0217 

0218 

0219 

0220 

0221 

Am  Am  A« 


IF<LU0*L7M»GR*LU0»6T»LIMIT)  GOTO  205 
1F(NSPP(1) *EQ*0)  203?  210 

202  IF  (LUO  <GE*  1 *AND*  LUO  ♦LE*  3)  203?  205 

203  LUO  = LUO  + 1 
GOTO  210 

205  WRITE(LUT?1050) 

GOTO  200 

210  CALL  DLISP  < PRCT ? SLPE ? NUMB ) 

NSPP(LUO)  = NUMB 

no  215  J = 1 ?NSPP  (LUO) 

SLOPE (LUO? J)  ~ BLPE(J) 

215  PERCNT(LUO? J) '=  PRCT(J) 

C USER  INPUT  ->  ANOTHER  MODIFICATION  ? 

WRITE(LUT? 1070) 

REAIKLUT? 1080)  IANS 

IFdANS  ♦NE*  2HYE)  GOTO  290 
IF  ( LER)  CALL  ERASE 
IF  ( LER)  CALL  HOME 
GOTO  200 

C SLOPES  AND  PERCENTS  ARE  CURRENT* 

C DOES  THE  USER  WANT  TO  VIEW  THEM  ? 

290  WRITE(LUT? 1090) 

READ (LUT? 1080)  IANS 

IFdANS  *NE*  2HYE)  RETURN 
WRITE  (LUT?2000) 

READ  (LUT? 1080)  IANS 

IF  (IANS*EQ*2HLP)  LUL  = 6 
IF  (IANS*EQ*2HLP)  KPASS  = 1 
GOTO  2 

C DOES  THE  USER  WANT  A LINE  PRINTER  COPY  ? 

300  WRITE  (LUT? 2010) 

READ  (LUT? 1080)  IANS 
IF  ( LER)  CALL  ERASE 
IF  ( LER)  CALL  HOME 
IF  (IANS*NE*2HYE)  RETURN 
LUL  = 6 

WRITE  (LUL?2020) 

KPASS  = 1 
GOTO  5 

C FORMAT  STATEMENTS 

999  FORMAT(lHl) 

1000  F0RMAT(/24X"CURRENT  SLOPE-PERCENT  PAIRSV 

> 24X*===  =======:=========  ======:==^V/ 

> 5(3X?4A2?4X)/ 

> 5( IX "SLOPE-PERCENT "IX)/ 

> 5(1X" "IX)/) 

1010  F0RMAT(74A1) 

C 

1020  F0RMAT(74( ) ) 

C 

1040  FORMAT (IX “SELECT:  1=>PR0CEED ? 2=>M0DIFY  SOME  SLOPES" 

> ‘ ?3=>RE-DEFINE  ALL  SLOPES  ->  _") 

C 

1050  FORMAT  (/?5X“ERR0R  ->  ILLEGAL  INPUT*  RE-SELECT“/) 

C 

1060  FORMAT  (//?5X*WHICH  ALTERNATIVE  DO  YOU  WANT  TO  MODIFY  ?“//? 


90 


0223 

0224 

0225 

0226 

0227 

0228 

0229 

0230 

0231 

0232 

0233 

0234 

0235 

0236 

0237 

0238 

0239 

0240 

0241 

0242 

0243 

0244 
r 0245 
^ 0246 

' 0247 

0248 
i 0249 
0250 
; 0251 

0252 

0253 

0254 

0255 

0256 

0257 

0258 

0259 

0260 
0261 
0262 


&7X'0)  NONE") 

1061  FORMAT < 

&7X-1)  CROPLAND •/» 

i7X"2)  NATIVE  VEGETATION ' /» 

S7X"3)  WILDLIFE'/^ 

S7X"4)  WATER  RECREATION */ » 

&7X-5)  HIGH  USE"//? 

&7X'ENTER  THE  APPROPRIATE  NUMBER  HERE  ->_* ) 

C 

1062  FORMAT ( 

&7X"1)  NATIVE  VEGETATION"/ 

•7X"2)  WILDLIFE"/ 

S7X"3)  WATER  RECREATION"// 

S"ENTER  THE  APPROPRIATE  NUMBER  HERE  ~>  _") 

C 

1063  FORMATC 

> 7X"1)  NATIVE  VEGETATION"/ 

> 7X"2)  WILDLIFE"/ 

> 7X"3)  WATER  RECREATION"/ 

> 7X"4)  HIGH  USE"// 

> 7X"ENTER  YOUR  SELECTION  HERE  ->  _") 

C 

1070  FORMAT  (/?5X"D0  YOU  HAVE  ANOTHER  MODIFICATION  ?"/? 

&5X"  (YES  OR  NO)  ->  _") 

C 

1080  FORMAT  (A2) 

C 

1090  FORMAT  </?5X"W0ULD  YOU  LIKE  TO  VIEW  THE  TABLE  AGAIN  ?"/? 
S5X"  (YES  OR  NO)  ->  _") 

C 

2000  FORMAT  (/?5X"W0ULD  YOU  LIKE  THE  TABLE  DISPLAYED  ON"/? 
X"THE  TERMINAL?  OR  THE  LINE  PRINTER  ? (TT  OR  LP )->_") 

C 

2010  FORMAT  (5X" WOULD  YOU  LIKE  A LINE  PRINTER  COPY  OF"/? 
&5X"THE  CURRENT  SLOPE  VALUES  ? (YES  OR  NO)  ->_“) 

C 

2020  FORMAT  (IHl) 

C 

END 

END$ 
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C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


c 


c 
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SUBROUT  I NL'  DLF CA  ( PL  ^ BC  y GA  r CD » ANACB  y ANPDE , 

> ANAGI > ANGHT I y GH  ? JK  r JL » KERR ) 

DRAGLINE  FINAL  CUT  : CORRECT  AREA 

LEVEL  6 

DLFCA  IS  ACCESSED  BY  DLGCF  TO  CORRECT  THE  CROSS-SECTIONAL  AREA 
COMPUTED  BY  DLFIA* 

THE  CALLING  SEQUENCE  IS  : 

CALL  DLFCA ( PL  y BC » GA  j CD » ANFDE  t ANAGI ? AR JDL  j GH » JK y JL » GK  y KERR ) 

where: 

•PL'  IS  THE  WIDTH  (FEET)  OF  THE  FINAL  HIGHWALL  (PHASE  1) 

OR  THE  SPOIL  BANK  (PHASE  2) 

•BC"  IS  THE  WIDTH  (FEET)  OF  THE  INITIAL  HIGHWALL  (PHASE  1) 

OR  THE  SPOIL  BANK  (PHASE  2) 

•GA*  IS  THE  WIDTH  (FEET)  OF  THE  HIGHWALL  (PHASE  1)  OR 
THE  SPOIL  BANK  (PHASE  2) 

•CD'  IS  THE  WIDTH  (FEET)  AT  THE  BOTTOM  OF  THE  PIT*  THIS  IS 
THE  CURRENT  WIDTHy  AND  MAY  DIFFER  FROM  THE  INITIAL 
WIDTH  DEFINED  BY  THE  USER  IN  DLFID* 

•ANACB"  IS  THE  INITIAL  SLOPE  (DEGREES)  OF  THE  HIGHWALL  (PHASE  1) 

OR  THE  SPOIL  BANK  (PHASE  2) 

•ANFDE'  IS  THE  INITIAL  SLOPE  (DEGREES)  OF  THE  SPOIL  BANK  (PHASE  1) 
OR  THE  FINAL  SLOPE  OF  THE  HIGHWALL  (PHASE  2) 

•ANAGI'  IS  THE  FINAL  SLOPE 

•ARGHTI*  IS  THE  (RETURNED)  AREA  (SQUARE  FEET)  CORRECTION 
•GH"  IS  THE  (RETURNED)  CORRECTION  (FEET)  OF  THE  HIGHWALL  (PHASE  1) 
OR  THE  SPOIL  BANK  (PHASE  2) 

•JK'  IS  THE  (RETURNED)  CORRECTION  (FEET)  ON  THE  SPOIL  BANK 
SLOPE  (PHASE  1)  OR  THE  HIGHWALL  SLOPE  FACE  (PHASE  2) 

■JL'  IS  THE  (RETURNED)  CORRECTION  (FEET)  TO  THE  FACE  OF  THE 

HIGHWALL  BANK  (PHASE  1)  OR  THE  SPOIL  BANK  FACE  (PHASE  2) 
■KERR'  IS  THE  ERROR  RETURN  CELL?.  0=>  NO  ERRORS y -1=>  ERROR 

LOCAL  VARIABLES  CORRESPOND  TO  THE  DIAGRAMS  IN  THE  CLAIM 
PROGRAMMER'S  MANUAL 

THIS  ROUTINE  WAS  WRITTEN  BY  GREEN 

CLAIM  RELEASE  1*0  - APRIL  ly  1980 

CDTR  = 0.01745 
KERR  = 0 

FIND  AREA  OF  JDL 
DL  = PL  - GA  - BC  - CD 
ANDJL  = 180.  - ANFDE  - ANAGI 

JL  = DL  t SIN  (ANFDE  t CDTR)  / SIN  (ANDJL  t CDTR) 

ARJDL  = (0.5)  t (JL)  t (DL)  t SIN  (ANAGI  t CDTR) 

NOW  FIND  THE  DISCRIMINANT 
GL  = PL  / COS  (ANAGI  t CDTR) 

GJ  = GL  - JL 

ANHKJ  = ANFDE  - ANAGI 


% 
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■0055 

0056 

10057 
0058 
0059 

10060 
0061 
0062 

10063 
0064 
0065 
0066 

Ij0067 
|0068 
0069 

10070 
i0071 
0072 
0073 
10074 
■0075 
0076 

10077 
0078 
0079 


IiENOM  = l/TAN(ANHKJ:|cCDTR)  - 1/TAN  < ANAGIi^'CDTR ) 

D = (GJ  2)  4-2.  t ARJDL  t DENOM 
IF  (D  *GE.  0.)  GOTO  10 
C COMPLEX  CONJUGATE  ROOTS 

KERR  = -1 
RETURN 

C REAL  ROOTS.  DETERMINE  RESULTS 

10  SQRTD  = SORT  CD) 

H = < SQRTD  - GJ)  / DENOM 
C WE  WANT  THE  ROOT  THAT  MAKES 

C PHYSICAL  SENSE  CGJ-C  > 0)  ■ 

C = H / TAN  (ANAGI  t CDTR) 

IF  CGJ  - C)  15y  20,  20 
15  H = (-1.  t SQRTD  - GJ)  / DENOM 
20  GH  = H / SIN  (ANAGI  t CDTR) 

JK  = H / SIN  CANHKJ  t CDTR) 

C FIND  AREA  CORRECTION  AND  RETURN 

AN6AI  = 180.  - ANACB 
ANAIG  = 180.  - ANAGI  - ANGAI 

HT  = (6A  - GH)  t (SIN  (ANGAI  t CDTR))  / (SIN  (ANAIG  t CDTR)) 
ARGHTI  = (.5>(«H:<c:^2))|c(l/  TAN  (ANAGI  t CDTR) 

> 4-  1 / TAN  (ANAIG  t CDTR))  4-  (HT  t H) 

RETURN 

END 

END$ 
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SUBROUTINE  BLFI A ( AB » ANAGI ? ANACB » PL y BC y 6A » ARAGI ) 


C DRAGLINE  FINAL  CUT;  INITIAL  AREA  DETERHINAT ION 

C 

C LEOEL  6 


C 


C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

c 

c 


DLFIA  IS  ACCESSED  BY  DLGCF  TO  CONFUTE  THE  INITIAL  CROSS-SECTIONAL 
AREA  BOUNDED  BY  THE  TRANGLE  “AGI‘  IN  THE  DIAGRAMS  PRESENTED  IN  THE 
CLAIM  PROGRAMMER'S  MANUAL.  THE  METHOD  IS  TO  FIND  THE  LENGTH  OF 
TWO  SIDES  OF  THE  TRIANGLE  AND  EMPLOY  THE  FORMULA: 

AREA  = (1/2) (A) (B)SIN(THETA) 

THE  CALLING  SEQUENCE  IS  : 

CALL  DLF I A < AB  y ANAGI y ANACB  y PL  y BC  y GA  y ARAGI ) 

where: 

•AB'  IS  THE  VERTICAL  HEIGHT  (FEET)  OF  THE  HI6HWALL  (PHASE  1) 

OR  THE  SPOIL  BANK  (PHASE  2) 

•ANAGI'  IS  THE  FINAL  SLOPE  (DEGREES)  OF  THE  HIGHWALL  S SPOIL  BANK 
•ANACB'  IS  THE  INITIAL  SLOPE  (DEGREES)  OF  THE  HIGHWALL  (PHASE  1) 

OR  THE  SPOIL  BANK  (PHASE  2) 

•PL*  IS  THE  (RETURNED)  WIDTH  (FEET)  OF  THE  FINAL  HIGHWALL  (PHASE  1) 

OR  THE  SPOIL  BANK  (PHASE  2) 

•BC*  IS  THE  (RETURNED)  WIDTH  (FEET)  OF  THE  INITIAL  HIGHWALL  (PHASE  1) 
OR  THE  SPOIL  BANK  (PHASE  2) 

•GA*  IS  THE  (RETURNED)  WIDTH  (FEET)  OF  THE  HIGHWALL  (PHASE  1) 

OR  THE  SPOIL  BANK  (PHASE  2)  REMOVED  BY  GRADING  (AT  THE  ‘TOP-) 
•ARAGI'  IS  THE  AREA  (SQUARE  FEET)  GRADED 

LOCAL  VARIABLES  CORRESPOND  TO  THE  DIAGRAMS  IN  THE  CLAIM 
PROGRAMMER'S  MANUAL. 


C THIS  ROUTINE  WAS  WRITTEN  BY  GREEN 
C 

C CLAIM  RELEASE  1.0  - APRIL  ly  1980 

C 

CDTR  = 0.01745 


C 

C 


C 

C 

C 


C 


ENDi^ 


IN  ORDER  TO  FIND  *GA*y  WE 
MUST  FIND  'PL'  AND  'BC* 

PL  = AB  / TAN  (ANAGI  t CDTR) 

BC  = AB  / TAN  (ANACB  t CDTR) 

GA  = (0.5)  t (PL  - BC) 

NOW  FIND  'GI'  BY  USING  THE 
LAW  OF  SINES  WITH  THE  ANGLES 
•ANGAI'  AND  “ANAIG* 

ANGAI  = 180  - ANACB 

ANAIG  = 180  - ANAGI  - ANGAI 

GI  =:  GA  t SIN  (ANGAI  t CDTR)  / SIN  (ANAIG  t CDTR) 

COMPUTE  THE  AREA  AND  QUIT 
ARAGI  = (0.5)  t (GA)  :(c  (GI)  « SIN  (ANAGI  t CDTR) 
RETURN 
END 
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XDLFID  T=00004  IS  ON  CR00015  USING  00029  BLKS  K-0000 


0001  FTN4 

0002 

0003  C 

0004  C 


SUBROUTINE  DLFID 

DRAGLINE  : FINAL  GUI  INITIAL  DATA 


0005  C LEVEL  2 

0006  C 

0007  C DLFID  IS  ACCESSED  BY  GDE  TO  SCHEDULE  INPUTS  AND  EDITS  TO 

0008  C THE  INITIAL  DATA  FOR  THE  DRAGLINE/FINAL  CUT  OPTION 

0009  C 

0010  C -lOPTN"  IS  A SWITCH  WHERE  t 

0011  Cl-  INPUT  MODE 

0012  C 2 - EDIT  MODE 

0013  C 3 - TEMPORARY  EDIT  MODE 

0014  C 

0015  C THE  CALLING  SEQUENCE  IS  t CALL  DLFID 

0016  C 

0017  C DLFID  USES  THE  TCS  ROUTINES  t ERASE  AND  HOME 

0018  C 

0019  C "IANS*  IS  THE  LOCAL  ANSWER  CELL 

0020  C "SLMIN"  IS  THE  CURRENT  MINIMUM  SLOPE  VALUE 

0021  C 

0022  C THIS  ROUTINE  WAS  WRITTEN  BY  GREEN?  BUT  PATTERNED  AFTER 

0023  C A ROUTINE  WRITTEN  BY  EASTMAN*  (GRADE) 

0024  C 

0025  C CLAIM  RELEASE  1<0  - APRIL  1?  1980 


0026  C 

0027  C 

0028  C 

0029  C 

0030 


COMMON  ITEK  (45) 


TEKTRONIX  COMMON 


0031  C 

0032  C 

0033  C 

0034 


LOGICAL  UNITS  AND  COMMON  LOCATION 


COMMON  IARRY(5) ? I ARY2 ( 5 ) ? LER ? LUF ? LUL 


0035  C 

0036  C 

0037  C 

0038 


POINTERS 


COMMON  EXIT  ?IANM(3) ? ICLI (2) ? IGEN ( 3 ) ? I6RW ( 5 ) 

COMMON  I OPTN  y I 0 VR ( 7 ) y I PNTR  y I SOC ( 6 ) y I SUB ( 8 ) 


0039 

0040' 

0041 

0042 

0043 


COMMON  ISUR(6) y IT0P(9) y I VEG ( 2 ) y LEXI T yLUO 
COMMON  MODE  yNANM  yNCLl  yNGEN  yNGRW 

COMMON  NOVR  yNSECTS  yNSOC  yNSUB  yNSUR 

COMMON  NTOP  yNU  yNVEG 


0044  C 

0045  C 

0046  C 

0047 


GRADING  PARAMETERS 


0048 

0049 


0050  C 

0051  C 

0052  C 

0053 


COMMON  ANIM(23y  13)  yCLMA(13y  13)  yGDESdSy  13)  yGWHY(22y  13) 
COMMON  0VBD(llyl3)rSBSL(13)y  SCEC(33y 13) y SWHY(44y 13) 


CATEGORY  TEXT 


0054 
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COMHON  TPSL(49,13) tVGTA(15> 13) 


0055 

0056  C 

0057  C 

0058  C 

0059 

0060 
0061 

0062  C 

0063  C 

0064  C 

0065 

0066 

0067 

0068  C 

0069  C 

0070  C 

0071 

0072 

0073 

0074 

0075 

0076 

0077  C 

0078 

0079 

0080 
0081 
0082 

0083 

0084 

0085 

0086  C 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094  C 

0095 

0096  C 

0097 

0098 

0099  C 

0100 
0101 
0102 

0103 

0104  C 

0105 

0106 

0107 

0108 

0109 

0110 


EXPECTATION  VALUES 


COHNON  ANIMAL (13? 6) ?CLIMAT(8?6) ?GENDES(8?6) ? GRWHYD ( 1 9 ? 6 ) 
COMMON  0VRBDN(28?6) ? SOCECN ( 29 ? 6 ) ? SUBSOI ( 30 ? 6 ) ? SURHYH ( 23 » 6 ) 
COMMON  T0PS0I(33?6) ? VEGETA ( 10 ? 6 ) 

CATEGORY  RESPONSES 

COMMON  RANIMA<3) ?RCL1MA(2) >RGENDE<3) ?RGRWHY(5) 

COMMON  RO VRBD ( 7 ? 1 0 ) ? RSOCEC  < 6 ) y RSUBSO ( 8 ) y RSURH Y ( 6 ) 

COMMON  RT0PS0<9) yRVEGET(2) 


FEASIyTECONyOPUSE  SUBSYSTEM  PARAMETERS 


COMMON  CAAHM » CABAH  y CABFN ( 3 ) y CABFP ( 3 ) y CABHM 

COMMON  CABS  < 2 ) y CAC  y CACP  ? CADF  y CABH 

COMMON  CADSy CAEAFy CAHSAF  yCAHSTSyCAIP 

COMMON  CAR3FC  y CASE  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRPy FAV6<5) y PFSTSP y PFAC y RCLTEC ( 29 y 34 ) 

COMMON  TCAR<5) y THI CK < 10 ) y THK I S y TTL ( 40 ) 


INTEGER  EXI T y CLMA  y GDES  y GUHY  y OVBD  y SBSL 
INTEGER  SCEC  y SUHY  y T PSL  y VGTA  y ANIM 
INTEGER  CLIMAT  y GENDES  y GRWH YD  y OVRBDN 
INTEGER  SOCECNySUBSOI ySURHYDy TOPSOI 
INTEGER  VEGETAy ANIMAL 

INTEGER  RCL I MA y RGENDE y RGRWHYy RO VRBD y RSOCEC 
INTEGER  RSUBSOyRSURHYyRTOPSOy RVEGETy RANIMA 
INTEGER  RCLTECyTTL 


INTEGER  COMMON  (1) 


EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 


(COMMON  (l)y 
(lARRY  (l)y 
(1ARY2  (l)y 
(IARY2  (2)y 
(IARY2  (3)y 
(IARY2  (4)y 


ITEK  (1)) 
LUT) 

ISTRK) 

ISECT) 

I CODE) 

LEN) 


LOGICAL  LER 


SLMIN  = 11 ♦ 

IF(M0DE*EQ*4)  SLMIN  = 0*1 
DISPLAY  THE  TITLE 

1 IF  (LER)  CALL  ERASE 
IF  (LER)  CALL  HOME 

EXIT=1 

WRITE(LUTy  1000) 

DISPLAY  CURRENT  DATA  FOR  EDIT  MODE  (lOPTN  = 2) 
IF  (I0PTN»EQ*1)  GOTO  20 
WRITE  (LUTy  1100)  WBPy  GRDVBSy  COGO 

2 READ  (LUIy  t)  IANS 

IF  (IANS*EQ*0)  GOTO  4 
IF  (IANS*GE»1*AND»1ANS*LE»7) 

>GOTO  ( 20y  30 y 40 y 50 y 60 y 70 y 80  ) IANS 
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C,  1 

0111 

WRITE  (LUT?  1110) 

0112 

GOTO  2 

! 

0113 

4 

1F(I0PTN*EQ»3)  I0PTN=1 

c 

0114 

RETURN 

011^ 

C 

USER  INPUT  ->  WIDTH  OF  BOTTOM  OF  PIT 

- 1 

0116 

20 

WRITE  (LUIt  1010) 

c 

0117 

READ  (LUTy  %)  WBP 

0118 

IF  <I0PTN*NE*1)  GOTO  1 

i 

0119 

IF  (WBP^GE.O*)  GOTO  30 

C''  1 

0120 

EXIT  = 0 

1 

! 

0121 

RETURN 

1 

1 

0122 

C 

USER  INPUT  ~>  LENGTH  OF  THE  PIT 

C i 

0123 

30 

WRITE  (LUTy  1030) 

1 

0124 

32 

READ  (LUTy  %)  GRDUBS  <1) 

1 

0125 

IF(GRD0BS(1) *GT*0* ) GOTO  33 

c. ' 

0126 

WRITE(LUTy 1085) 

--  ! 

0127 

GOTO  32 

i 

0128 

33 

IF  (I0PTN*NE»1)  GOTO  1 

C*  i 

0129 

C 

USER  INPUT  ~>  HEIGHT  OF  THE  HIGHWALL 

, 1 

0130 

40 

WRITE  (LUTy  1040) 

h 1 
1 

0131 

42 

READ  (LUTy  %'i  GRDUBS  (2) 

C'l  1 

0132 

IF(6RD0BS(2) *GT*0. ) GOTO  43 

- ■ 1 

0133 

WRITE(LUTy 1085) 

"i  i 

0134 

GOTO  42 

C 

0135 

43 

IF  (I0PTN»NE*1)  GOTO  1 

-•  i 

0136 

C 

USER  INPUT  ~>  HEIGHT  OF  SPOIL  BANK 

! 

0137 

50 

WRITE  (LUTy  1050) 

0138 

52 

READ  (LUTy  %)  GRDOBS  (3) 

$ ! 

0139 

IF(GRD0BS(3) ♦6T ^O* ) GOTO  53 

J 

0140 

WRITE(LUf y 1085) 

k ■ 

0141 

GOTO  52 

^ ! 
O - 

0142 

53 

IF  (lOPTN.NE^l)  GOTO  1 

A 

</■* 

T 

0143 

C 

USER  INPUT  ->  SLOPE  OF  HIGHWALL 

iC,  : 

0144 

60 

WRITE  (LUTy  1060) 

U--  •-. 

o:  — 

o 

0145 

READ  (LUTy  5^0  GRDUBS  (4) 

o ^ 
s - 

0146 

IF  (6RD0BS  (4) ♦GE»SLMIN*AND*GRDOBS  (4)*LT*90* 

!C 

0147 

>GOTO  ( 70ylyl  ) lOPTN 

23  3 

< - 

0148 

WRITE  (LUTy  1065)  SLMIN 

0149 

GOTO  60 

c.  , 

0150 

C 

USER  INPUT  ->  SLOPE  OF  THE  SPOIL 

- 

0151 

70 

WRITE  (LUTy  1070) 

0152 

READ  (LUTy  GRDOBS  (5) 

C ■ 

0153 

IF  (GRDOBS  (5) ♦GE*SLMIN*AND*GRDOBS  (5)*LT*90* 

0154 

>GOTO  ( eOylyl  ) lOPTN 

- - 

0155 

WRITE  (LUTy  1065)  SLMIN 

■ 

0156 

GOTO  70 

0157 

C 

USER  INPUT  ~>  COST  OF  GRADING  SPOILS 

- 

0158 

80 

WRITE  (LUTy  1080) 

('1  i 

0159 

82 

READ  (LUTy  t)  COGO 

0160 

IF(C0G0*GT*0* ) GOTO  83 

-21  \ 

0161 

WRITE(LUry 1085) 

C 1 

0162 

GOTO  82 

■ 

0163 

83 

IF  (I0PTN*NE*1)  GOTO  1 

0164 

I0PTN=3 

c 

0165 

GOTO  1 

0166 

C 

FORMAT  STATEMENTS 

c 
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0167 

0168 

0169 

0170 

0171 

0172 

0173 

0174 

0175 

0176 

0177 

0178 

0179 

0180 

0181 

0182 

0183 

0184 

0185 

0186 

0187 

0188 

0189 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

0197 

0198 

0199 

0200 

0201 

0202 

0203 

0204 


1000  FORMATC//' 


DRAGLINE/FINAL  CUT  ■//) 


HIGHWALL 
SPOIL  BANK 


1100  FORMAT</y 5X'CURRENT  VALUES  FOR  THE  DATA 
&7X"1)  WIDTH  OF  THE  BOTTOM  OF  THE  PIT 
TOTAL  LENGTH  OF  THE  PIT 
VERTICAL  HEIGHI 
VERTICAL  HEIGHT 
INITIAL  AVERAGE 
HIGHWALL 
INITIAL  AVERAGE 
SPOIL  BANK 

OF  GRADING  SPOILS 


&7X*2) 
&7X-3) 
&7X'4) 
&7X*5) 
&7X" 
>7X'6) 
>7X' 
S7X'7) 
SIX 
S2X 
S2X 


OF  THE 
OF  THE 
SLOPE  OF 


THE 

SLOPE  OF  THE 


/y 


COST 


ARE  :•/, 
F13*2* 


♦ V 
k 


4 ff 
4 


F13.2* 


F13»2" 
: •F13*2* 


4 • 

4 


FEETVy 
YARDS '/y 
FEETVy 
FEETVy 


4 ■ 

4 


F13.2'  DEGREES Vy 


: 'F13*2* 


4 ff 
4 


IF  YOU  WISH  TO  CHANGE  ANY  OF  THE  ABOVE 
THE  NUMBER  CORRESPONDING  TO  THE  ITEM  YOU 
IF  NO  CHANGES  ARE  DESIRED y ENTER  A ZERO 


DEGREES “/y 
CENIS/CU* YD 
VALUES?  ENTERVy 


F13*2* 


/// 


WISH 


SH  TO 
_*  ) 


CHANGE*  Vy 


1110  FORMAT(/y 5X*ERR0R — > ILLEGAL  CHOICE ♦ RE~SELECT ♦ 


• ) 


1010  FORMAT(/*WIDTH  OF  BOTTOM  OF  THE  PIT  <FEET)“>_*) 

C 

1030  FORMAT(/'TOTAL  LENGTH  OF  THE  PIT  (YARDS)  ->  _") 

C 

1040  FORMAT(/"VERTICAL  HEIGHT  OF  THE  HIGHWALL  (FEET)  ~>  _") 

C 

1050  FORMAT(/'VERTICAL  HEIGHT  OF  THE  SPOIL  BANK  (FEET)  ->  _") 

C 

1060  FORMAT(/* AVERAGE  INITIAL  SLOPE  OF  THE  HIGHWALL  (DEG)  ->  _*) 

C 

1065  FORMAT (/2X‘ ERROR  ->  SLOPE  MUST  BE  BETWEEN  'F5*2"  DEGREES  V 
> 2X*  AND  90  DEGREES*  V) 

C 

1070  FORMAT(/' AVERAGE  INITIAL  SLOPE  OF  THE  SPOIL  BANK  (DEG)  ->  _*) 
C 


1080  FORMAT (/'COST  OF  GRADING  SPOILS  ( CENTS/CU * YD ) ~>  _“) 

C 

1085  FORMAT(/y lX*ERROR->  VALUE  MUST  BE  GREATER  THAN  ZERO  -■>_•) 
END 

END$ 
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SDL6CM  1=00004  IS  ON  CR00015  USING  00019  BLKS  F<==0181 


0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 
0027 

' 0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 

0053 

0054 


FTN4 

SUBROUTINE  DLGCN  ( SLOP , F‘CT » OOL y COST » TLSB y GRDOBS ? COG ) 

C DRAGLINE  GRADING  COMPUTATIONS  : MINE  RUN  

C 

C LEOEL  5 
C 

C DLGCM  IS  ACCESSED  BY  DLGE y BUILD y AND  DLST  AND  BUILD  TO  DETERMINE 
C VOLUMES y COSTS y AND  COSTS  PER  ACRE  FOR  THE  MINE  RUN 
C OPTION* 

C 

C THE  VARIABLE  "KOBE*  DIRECTS  DLGCM  TO  PLACE  THE  RESULTS 
C IN  TABLES  (K0DE=2)y  OR  DIRECTLY  TO  VOL  AND  COST  ARRAYS 
C (K0DE=1) 

C 

C THE  CALLING  SEQUENCE  IS  J 
C 

C CALL  DLGCM ( SLOP  y PCT  y VOL  y COST  y TLSB  y GRDVBS  y COG ) 

C 

c where: 

C 

C SLOP  IS  THE  FINAL  SLOPE  (DEGREES)  DESIRED  ON  THE  SPOIL  BANKS 

C PCT  IS  THE  PERCENT  OF  THE  AREA  TO  BE  COVERED  BY  SLOP 

C VOL  IS  THE  VOLUME  (CUBIC  YARDS)  GRADED 

C COST  IS  THE  COST  (DOLLARS)  TO  GRADE  SPOILS 

C TLSB  IS  THE  HYPOTHETICAL  TOTAL  LENGTH  (FEET)  OF  A SPOIL  BANK 

C COVERING  THE  SAME  ACREAGE  AS  THE  MINE  RUN  SPOILS 

C GRDVBS  IS  THE  GRADING  VARIABLES  ARRAY: 

C GRDVBS  (1)  ->  DISTANCE  (FEET)  BETWEEN  SPOIL  BANK  PEAKS 

C GRDVBS  (2)  ->  SLOPE  (DEGREES)  OF  THE  SPOIL  BANKS 

C GRDVBS  (3)  ->  AREA  (ACRES)  COVERED  BY  THE  SPOILS 

C GRDVBS  (4)  ->  GENERAL  SLOPE  (DEGREES)  OF  THE  AREA 

C PERPENDICULAR  TO  THE  SPOILS 

C COG  ->  COST  (CENTS/CUBIC  YARD)  OF  GRADING  OVERBURDEN 

C 

C LOCAL  VARIABLES  CORRESPOND  TO  THE  DIAGRAMS  IN  THE 
C CLAIM  PROGRAMMER'S  MANUAL 


C 

C DLGCM  DECLARES  LABEL  COMMON  TABLE 
C 

C THIS  ROUIINE  WAS  WRITTEN  BY  EASTMAN/GREEN 
C 

C CLAIM  RELEASE  1*0  ~ APRIL  ly  1980 

C 

COMMON  /TABLE/ 

> TBLVy  TBLTy  TBLAy  TBLSy  JCOUNT y TSMIN y KOBE y 

> TSMAXy TVMINy TVMAXy TAMINy TAMAXy TTMINy TTMAX 
C 

DIMENSION  TBLV(12) y TBLT ( 12 ) y TBLA ( 12 ) yTBLS(12) 

DIMENSION  GRDVBS(5) 

C 

C CONVERT  GRDBVS  TO  VARIABLES  CORRESPONDING  TO 

C THE  DIAGRAMS  IN  THE  PROGRAMMER'S  MANUAL 

DBSBP  = GRDVBS(l) 

SLOPI  = GRDVBS (2) 
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0055 

TASA 

= GRDMBS(3) 

0056 

AGH  = 

GRDVBS(4) 

0057 

C 

CONOERT  TASA  TO  SQUARE  YARDS 

0058 

TASY 

= TASA  t 4840. 

0059 

C 

CALCULATE  A HYPOTHETICAL  LENGTH  FOR 

THE  SPOILS 

0060 

SHEAY 

= SQRT  (TASY) 

0061 

SHEAF 

==  SHEAY  t 3. 

0062 

BANKS 

= SHEAF  / DBSBP 

0063 

TLSB 

= BANKS  t SHEAY 

0064 

C 

•CDTR"  CONCERTS  FROM  DEGREES  TO 

RADIANS 

0065 

CDTR 

= 0.01745 

0066 

RAGH 

= AGH  t CDTR 

0067 

C 

CONOERT  COG  TO  DOLLARS 

0068 

COMO 

= COG  / 100. 

0069 

RSLOPI  = SLOPI  ^ CDTR 

0070 

C 

CALCULATE  THE  AREA  OF  THE  CROSS-SECTION  OF  THE  PART 

0071 

C 

OF  THE  SPOIL  BANK  THAT  IS  TO  BE  MOOED. 

0072 

C 

CONOERT  THE  DISTANCE  BETWEEN  SPOIL 

BANK  PEAKS  FROM 

0073 

C 

FEET  TO  YARDS. 

0074 

AG  = 

DBSBP/3. 

0075 

61  = 

AG  t SIN(RAGH) 

0076 

AI  = 

AG  t COS (RAGH) 

0077 

IH  = 

61  / TAN(RSLOPI) 

0078 

GH  = 

GI  / SIN (RSLOPI) 

0079 

AH  = 

AI  + IH 

0080 

AJ  = 

AH  / 2. 

0081 

HJ  = 

AJ 

0082 

C 

NOW  FIND  THE  AREA  OF  THE  LEFT  TRIANGLE  TO  BE  MOOED 

0083 

AD  = 

AJ  / COS(RSLOPI) 

0084 

CD  = 

AD/2. 

0085 

CDL  = 

90.  - SLOPI 

0086 

DCL  = 

90.  - SLOP  - CDL 

0087 

DLC  = 

180.  - CDL  - DCL 

0088 

C 

CONOERT  TO  RADIANS  FROM  DEGREES 

0089 

RCDL 

= CDL  t CDTR 

0090 

RDCL 

= DCL  t CDTR 

0091 

RDLC 

= DLC  t CDTR 

0092 

C 

CALCULATE  THE  AREA  OF  THE  TRIANGLE 

0093 

AREAL 

= ((CD  t CD)  t SIN(RCDL)  t SIN(RDCD)  / 

(2  t SIN(RDLO) 

0094 

C 

NOW  FIND  THE  AREA  OF  THE  OTHER  TRIANGLE  TO  BE  MOOED 

0095 

DH  = 

HJ  / COS (RSLOPI) 

0096 

DG  =•• 

DH  - GH 

0097 

0098 

0099 

0100 
0101 
0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


C 

C 

C 

C 


DE  = 
ELiL  = 
DLE  = 
DEL  = 
F<EDL  : 
F\DLE  = 
RDEL  = 

AREAR 


AREA 


DG/2* 

: 90*  - 
: 90*  + 

^ SLOPI  - 
==  EDL  t 
= DLE  t 
= DEL  t 
NOW 


SLOPI 
SLOP 
- SLOP 
CDTR 
CDTR 
CDTR 

CALCULATE 


THE  AREA  OF  THE  TRIANGLE 


= (<DE  t DE)  t SIN(REDL)  SIN<RDED)  / ( 2>S?SIN < RULE ) ) 
TOTAL  AREA  TO  EE  HOOED  =:  SUM  OF  AREAS  OF  LEFT 
AND  RIGHT  TRIANGLES 
AREAR  -f  AREAL 

CALCULATE  THE  PERCENT  OF  THE  TOTAL  LENGTH  OF  THE 
SPOIL  BANKS 


100 


PLEN 


0111 

0112 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120 
0121 
0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 


C 

C 

C 

C 

\ 

C 


(PCT  /lOO*)  t TLSB 


CALCULATE  THE  VOLUHE 
OOL  = PLEN  t Af<EA 

THE  VOLUME  IS  IN  CUBIC  YAF<DS 
ADD  TO  TOTAL  VOLUME 
CALCULATE  THE  COST 
COST  =:  VOL  t COMO 

NOW  COMPUTE  7 HE  COST  PEP  ACRE 
CPA  = COST  / TASA 
IF(SLOP*NE*SLOPI)  GOTO  150 
V0L=0* 

C0ST==0* 

CPA=:0  ♦ 


150  CONTINUE 

IF<K0DE>NE*2)  RETURN 
TBLS(JCOUNT)  = SLOP 
TBLV<JCOUNT)  = VOL 
TBLT(JCOUNT)  = COST 
TBLA(JCOUNT)  = CPA 
RETURN 
END 


END$ 
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0004 
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0018 

0019 
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0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 
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0041 

0042 

0043 

0044 
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FfN4 

SUBROUTINE  DLGCF  < SLOP  ? POT  y WBP  y 6RD0BS  y C060  y VOL  y COST  y ACRES ) 

C BRAGLINE  GRADING  COMPUTATIONS  t FINAL  CUT  

C 

C LEVEL  5 
C 

C DLGCF  IS  ACCESSED  BY  DLGEyBUILDy  AND  DLST  TO  PERFORM 
C GRADING  CALCULATIONS  FOR  THE  FINAL  CUT  STAGE  OF  A 
C DRAGLINE  MINE* 

C 

C DLGCF  CONSISTS  OF  THREE  PHASES  : 

C 1)  HIGHWALL  GRADING 

C 2)  SPOIL  BANK  GRADING 

C 3)  VOLUMEyCOSTy  AND  AREA  DETERMINATION 

C 

C DLGCF  CALLS  SUBROUTINES  DLFIA  AND  DLFCA  TO  DETERMINE  THE 
C INITIAL  CROSS-SECTIONAL  AREA  REMOVED  BY  GRADING  AND  THE 
C CORRECTION  TO  THAT  AREA  (IF  NEEDED) y RESPECTIVELY. 

C 

C THE  CALLING  SEQUENCE  IS  I 

C CALL  DLGCF ( SLOP  y PCT  y WBP  y GRDVBS  y COGO  y VOL  y COST  y ACRES ) 

C WHERE  : 

C “SLOP*  IS  THE  FINAL  SLOPE  DESIRED  ON  THE  HIGHWALL 
C AND  THE  SPOIL  BANK  (DEGREES) 

C "PCT*  IS  THE  PERCENT  OF  THE  AREA  TO  BE  COVERED  BY  'SLOP*  (%) 

C "WBP*  IS  THE  WIDTH  AT  THE  BOTTOM  OF  THE  PIT  (FEED 
C -GRDVBS*  IS  THE  GRADING  VARIABLES  ARRAY  As  INITIALIZED  IN  DLFID 
C -COGO-  IS  THE  COST  OF  GRADING  OVERBURDEN  (CENTS/CUBIC  YARD) 

C -VOL-  IS  THE  (RETURNED)  VOLUME  GRADED  (CUBIC  YARDS) 

C -COST-  IS  THE  (RETURNED)  COST  FOR  GRADING  TO  -SLOP*  (DOLLARS) 

C -ACRES-  IS  THE  (RETURNED)  FINAL  AREA  COVERED  BY  THE  SPOILS  (ACRES) 
C 

C LOCAL  VARIABLES  CORRESPOND  TO  THE  DIAGRAMS  IN  THE  PROGRAMMER'S 
C MANUAL. 

C 

C THIS  ROUTINE  WAS  WRITTEN  BY  GREEN 
C 

C CLAIM  RELEASE  1.0  - APRIL  ly  1980 

C 

COMMON  /TABLE/ 

> TBLVy  TBLTy  TBLAy  TBLSy  JCOUNT y TSMI N y KOBE y 

> TSMAXy  TVMIN  y TVMAXy  TAMINy  TAMAX  y TTMIN  y TTMAX 
C 

DIMENSION  TBLV(12) yTBLT(12) yTBLA(12) y TBLS(12) 

C 

DIMENSION  GRDVBS(l) 

C LET'S  START  BY  CONVERTING  THE 

C ARGUMENTS  TO  NOMENCLATURE 

C CORRESPONDING  TO  THE  DIAGRAMS 

AN AG I = SLOP 
CD  = WBP 
ABl  =••  GRDVBS(2) 

AB2  = GRDVBS(3) 

C 


note: 


1-  AND 


If  ■ 


ARE  APPENDED 


0055 

0056 

0057 

0058 

0059 

0060 

0061 

0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 

0081 

0082 

0083 

0084 

0085 

0086 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 

0101 

0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


C TO  THE  VARIABLE  NAHES  TO 

C DISTINGUISH  BETWEEN  PHASE  1 & 2 

ANACBl  = GRDVBS(4) 

ANACB2  = 6RDVBS(5) 

C INITIALIZE  PARAMETERS 

MOL  = 0* 

COST  = 0* 

ACRES  =0* 

CDTR  = 0*01745 
ARGHTl  =0* 

ARGHT2  = 0* 

C INITIATE  PHASE  1 I HIGHWALL  GRADING 

CALL  DLFIACABl jANAGI > ANACBl ?PL1 jBCI yGAl jARAGII ) 

IF  (GAl  ~ CD)  110,  110,  150 
C SITUATION  ONE  I ADJUST  CD 

110  LD  = GAl  + BCl  + CD  - PLl 
CD  = CD  - LD 
GOTO  200 

C SITUATION  TWO  : CORRECT  AREA 

150  CALL  DLFCA  ( PLl , BCl , GAl , CD , ANACBl , ANACB2 , 

ANAGI , ARGHTl , GHl , JKl , JLl ? KERR ) 

IF  (KERR  *EQ*  0)  GOTO  160 

<ERROR  FLAG>  RETURN 

ACRES  = -I* 

RETURN 
= 0* 

INITIATE  PHASE  2:  SPOIL  BANK  GRADING 
IF  (CD  *GT*  0*)  GOTO  225 

DJ  = JLl  t SIN(ANAGI)KCDTR)  / SIN ( ANACB23(iCDTR ) 

DK  = DJ  + JKl 

BB  = DK  t SIN(ANACB2>fcCDTR) 

AB2  = AB2  - BB 
GAl  = GAl  - GHl 

225  CALL  DLFIA(AB2, ANAGI ,ANACB2,PL2,BC2,GA2,ARAGI2) 

IF  (GA2  - CD)  300,  300,  230 
C CORRECT  OMERGRADING 

230  CALL  DLFCA  ( PL2 , BC2 , GA2 , CD , ANACB2 , ANAGI , 

> ANAGI , ARGHT2 , GH2 , JK2 , JL2 , KERR ) 


C 

155 

160  CD 
C 

200 


IF  (KERR  *NE*  0)  GOTO  155 
GA2  = GA2  - GH2 


C PHASE  3 : VOLUME,  COST 

300  IF(ARGmi  T ARGHT2)  155,  310,  310 
310  VOL  = ( (ARAGIl  - ARGHTl)  + (ARAGI2  - 
> (PCT  / 100*)  t (GRDVBS(D)  / 9* 

COST  = VOL  t COGO  / 100* 

ACRES  = (GAl  + GA2  + BCl  T BC2  + WBP) 


C 


END$ 


> 3 *743560*  t PCT  / 100* 


IF(K0DE*NE*2) 
TBLS( JCOUNT) 
TBLV( JCOUNT) 
TBLT( JCOUNT ) 
TBLA( JCOUNT) 


RETURN 
= SLOP 
=••  VOL 
= COST 

= COST/ACRES 


RETURN 


END 


AND  AREA 
ARGHT2)  ) 


t GRDVBS(l) 
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SUBROUTINE  DLGCO  ( SLOP  > PCT  » OOL , COST , CPA  y GRDOBS  y COG  y WIDTH ) 

C DRAGLINE  GRADING  COMPUTATIONS  : OPENING  CUT  

C 

C LEOEL  5 
C 

C DLGCO  IS  ACCESSED  BY  DLGE y BUILD y AND  DLST  AND  BUILD  TO  DETERMINE 
C OOLUMESy  COSTSy  AND  WIDTHS  FOR  THE  OPENING  CUT  OPTION* 

C 

C THE  VARIABLE  “KOBE*  TELLS  DLGCO  TO  PLACE  RESULTS  IN 
C THE  TABLES  (K0DE=2)  OR  IN  VOL  AND  COST  (K0DE=1)* 

C 

C THE  CALLING  SEQUENCE  IS  : 

C 

C CALL  DLGCO ( SLOP  y PCT  y VOL  y COST  y CPA  y GRDVBS  y COG  y W I DTH ) 

C 

c where: 


C 

C 

C 

c 

c 

c 

c 


c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


c 

c 

c 

c 

c 


c 


c 


c 

c 

c 


SLOP  IS  THE  FINAL  SLOPE  (DEGREES)  DESIRED  ON  THE  SPOIL  BANK 
PCT  IS  THE  PERCENTAGE  OF  THE  AREA  TO  BE  COVERED  BY  SLOP 
VOL  IS  THE  (RETURNED)  VOLUME  (CUBIC  YARDS)  GRADED 
CPA  IS  THE  (RETURNED)  COST  (DOLLARS/ACRE)  TO  GRADE  SPOILS 
GRDVBS  IS  THE  GRADING  VARIABLES  ARRAY  : 

GRDVBS  (1)  “>  HEIGHT  (FEET)  OF  THE  SPOIL  BANK 
GRDVBS  (2)  ->  SLOPE  (DEGREES)  OF  THE  SPOIL  BANK 
GRDVBS  (3)  ->  LENGTH  (FEET)  OF  THE  SPOIL  BANK 
GRDVBS  (4)  ->  SLOPE  (DEGREES)  OF  THE  AREA 

PERPENDICULAR  TO  THE  SPOIL  BANK 
GRDVBS  (5)  ->  NOT  USED 

COG  IS  COST  (CENTS/CUBIC  YARD)  OF  GRADING  OVERBURDEN 
WIDTH  IS  THE  (RETURNED)  FINAL  WIDTH  OF  THE  SPOIL  BANK 

THE  LOCAL  VARIABLES  CORRESPOND  TO  THE  DIAGRAMS  IN  THE 
CLAIM  PROGRAMMER'S  MANUAL 

DLGCO  REQUIRES  LABEL  COMMON  TABLE 

THIS  ROUTINE  WAS  WRITTEN  BY  EASTMAN/GREEN 

CLAIM  RELEASE  1*0  - APRIL  ly  1980 

COMMON  /TABLE/ 

> TBLVy  TBLTy  TBLAy  TBLSy  JCOUNT y TSMIN y KOBE y 

> TSMAXy TVMINy TVMAXy  TAMINyTAMAXy TTMINy T TMAX 

DIMENSION  TBLV(12) yTBLT(12) yTBLA(12) yTBLS(12) 

DIMENSION  GRDVBS  (5) 


RENAME  GRDVBS  ELEMENTS  TO  VARIABLES  CORRESPONDING  TO 
THE  DIAGRAMS  IN  THE  CLAIM  PROGRAMMER'S  MANUAL* 

BQ  = GRDVBS  ( 1 ) 

SLOP  I ==  GRDVBS  (2) 

TLSB  = GRDVBS  (3) 
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0055 

QAR 

= GRDOBS  (4) 

0056 

1 r < SLOP ♦ LQ . QAR ) SLOP=SLOP+ ♦ 001 

* 

0057 

C 

CONCERT  COG  TO  DOLLARS 

0058 

COGO 

= COG  / 100. 

0059 

C 

CALCULATE  THE  AREA  OF  THE 

CROSS-SECTION  OF  THE  PART 

0060 

C 

OF  THE  SPOIL  BANK  THAT  IS 

TO  BE  MOVED* 

0061 

C 

CONVERT  THE  HEIGHT  OF  THE 

SPOIL  BANK  FROM 

0062 

C 

FEET  TO  YARDS* 

0063 

BQl  = 

BQ/3* 

0064 

BAR  = 

SLOPI 

0065 

BAQ  = 

BAR  - QAR 

0066 

BQA  = 

90*  + QAR 

0067 

ABQ  = 

180*  - BAQ  - BQA 

0068 

C 

•CDTR*  CONVERTS  FROM 

DEGREES  TO  RADIANS 

0069 

CDTR 

= 0*01745 

0070 

RABQ 

= ABQ  t CDTR 

0071 

RBQA 

= BQA  t CDTR 

0072 

RBAQ 

= BAQ  t CDTR 

0073 

ATBAQ 

= <<BQ1  t BQl)  t SIN(RABQ)  t 

SIN(RBQA))  / (.2%  SIN(RBAQ)) 

0074 

BTP  = 

SLOPI 

0075 

BTQ  = 

BTP  + QAR 

0076 

BQT  = 

90*  - QAR 

0077 

QBT  = 

180*  - BTQ  - BQT 

0078 

RBQT 

= BQT  t CDTR 

0079 

RQBT 

= QBT  t CDTR 

0080 

RBTQ 

= BTQ  t CDTR 

0081 

ATBTQ 

= ((BQl  )(c  BQl)  t SIN(RBQT)  t 

SIN  (RQBT))  / (2  )tc  SIN  (RBTQ)  ) 

0082 

ATBAT 

= ATBAQ  + ATBTQ 

0083 

ATXYS 

= ATBAT 

0084 

YWR  = 

SLOP 

0085 

YXQ  = 

YWR  - QAR 

0086 

XYQ  = 

90*  - YWR 

0087 

YSX  = 

YWR  + QAR 

0088 

QYS  = 

XYQ 

0089 

XYS  = 

XYQ  + QYS 

0090 

YXS  = 

YXQ 

0091 

RXYS 

= XYS  t CDTR 

0092 

RYXS 

= YXS  ^ CDTR 

0093 

RYSX 

= YSX  t CDTR 

0094 

XY  = 

SQRT( (ATXYS  t 2.  t SIN(RYSX)) 

/ (SIN(RXYS)  % SIN(RYXS))  ) 

0095 

YS  = 

SORT ((ATXYS  t 2.  t SIN (RYXS)) 

/ (SIN(RYSX)  % SIN(RXYS))) 

0096 

C 

NOW  FIND  THE  AREA  OF  TRIANGLE  BVY 

0097 

YQS  = 

BQT 

0098 

YSQ  = 

YWR  + QAR 

0099 

RQYS 

= QYS  t CDTR 

0100 

RYSQ 

= YSQ  t CDTR 

0101 

RYQS 

= YQS  t CDTR 

0102 

ATYSQ 

= ((YS  YS)  SIN(RQYS)  )fc  SIN(RYSQ))/  (2*  t SIN(RYQS)) 

0103 

QS  = 

SQRT(  (ATYSQ  t 2.  t SIN(RQYS)) 

/ ( SIN(RYSQ)  % SIN(RYQS))  ) 

0104 

QT  = 

SQRT(  (ATBTQ  t 2.  t SIN(RQBT))  / ( SIN(RBQT)  t SIN(RETQ))  ) 

0105 

TS  = 

QS  - QT 

0106 

OST  = 

YSQ 

0107 

STV  = 

180*  - BTQ 

0108 

TVS  = 

180*  - VST  - STV 

0109 

RSTO 

= STV  t CDTR 

0110 

• 

RTVS 

= TVS  t CDTR 
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0111 

0112 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120 
0121 
0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 


08  = (SINCRSTO)  t IS  ) / SIN(RTOS) 

YO  = YS  - 08 
Y80  = QBT 
BOY  =•*  T08 

BYO  = 180*  - YBO  - BOY 
RBOY  = BOY  t CDTR 
RBYO  = BYO  t CDTR 
RYBO  = YBO  t CDTR 

C ATBOY  18  THE  AREA  OF  TRIANGLE  BOY 

ATBOY  = <<Y0  t YO)  t SIN<RBOY)  t SIN(RBYO))  / (2*  t 8IN(RYB0)) 
C NOW  FIND  THE  AREA  OF  TRIANGLE  BUY 

BY  = ( 8IN(RB0Y)  ^ YKf  ) / SIN(RYBO) 

UBY  = ABQ 

BUY  - BAR  - YWR 

BYU  = 180*  - UBY  - BUY 

RUBY  = UBY  t CDTR 

RBYU  = BYU  t CDTR 

RBUY  = BUY  t CDTR 

ATBUY  = ((BY  ^ BY)  ^ SIN(RUBY)  t SIN(RBYU))  / (2*  t SIN(RBUY)) 
C TOTAL  AREA  TO  BE  HOOED  = BUM  OF  AREAS  OF  LEFT  AND 

C RIGHT  TRIANGLES 

AREA  = ATBOY  + ATBUY 
XS  = (SIN(RXYS)  t YS)  / SIN(RYXS) 

C XS  IS  THE  WIDTH  OF  THE  FINAL  SF’OIL  BANK* 

C CONOERT  TO  FEET 

WIDTH  = XS  t 3. 

C CALCULATE  THE  PERCENT  OF  THE  TOTAL  LENGTH  OF  THE 

C SPOIL  BANKS 

PLEN  = (PCT  /lOO*)  t TLSB 

C CALCULATE  THE  OOLUME 

OOL  ==  PLEN  t AREA 
C CALCULATE  THE  COST 

COST  = OOL  t COGO 

C CALCULATE  THE  COST  PER  ACRE 

ACRES  = (PLEN  t XS)/4840* 

CPA  = COST/ACRES 

IF(SL0P*NE*SL0P1)  GO  TO  150 
OOL  =:  0* 

COST  = 0* 

CPA  = 0* 

150  CONTINUE 


1F(K0DE*EQ*1)  TSMAX^WIDTH 
IF(K0DE*NE*2)  RETURN 
TBLS(JCOLINT)  = SLOP 
TBLO(JCOUNT)  = OOL 
TBLT(JCOUNT)  = COST 
TBLA(JCOUNT)  = WIDTH 
RETURN 
END 

END$ 
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FTN4 

C 

C 


SUBROUTINE  DLGE 

DRAGLINE  GRADING  EXECUTIVE  


C LEVEL  2 
C 

C DLGE  IS  ACCESSED  BY  6DE  TO  GRADE  THE  SPOILS 
C TO  THE  FINAL  TOPOGRAPHY  SPECIFIED  BY  THE  USER* 
C 


C GRAPHS  DISPLAYING  THE  DRAGLINE  RELATIONSHIPS  : 

C FINAL  SLOPE  VS*  VOLUME  GRADEDt 

C FINAL  SLOPE  VS*  GRADING  COST, 

C AND  FINAL  SLOPE  VS*  FINAL  WIDTH  (OPENING  CUT) 

C OR  FINAL  SLOPE  VS*  COST  PER  ACRE  (MINE  RUN  AND  OR  FINAL  CUT) 

C ARE  AVALIABLE  AT  THE  USER^S  REQUEST* 

C 


C RECOMMENDED  SLOPE  AND  PERCENT  PAIRS  ARE  ALSO  PRESENTED 
C AND  MAY  BE  USED  AS  DISPLAYED,  OR  EDITED  ACCORDING  TO  THE 
C USER'S  PREFERENCE* 

C 

C SUMMARY  TABLES  DISPLAYING  THE  VOLUMES  AND  COSTS 
C ASSOCIATED  WITH  GRADING  TO  THE  USER  SPECIFIED  FINAL 
C TOPOGRAPHY  ARE  AVAILABLE  AT  USER  REQUEST  ON  THE 
C TERMINAL  OR  THE  LINE  PRINTER* 

C 

C THE  CALLING  SEQUENCE  IS  : CALL  DLGE 

C 

C SUBROUTINES  SCHEDULED  BY  DLGE  ARE  : 

C 

C DLRLE  TO  PRESENT  THE  DRAGLINE  RELATIONSHIPS 

C DLRSL  TO  READ  THE  RECOMMENDED  SLOPE/PERCENT  PAIRS 

C DLDCS  TO  DISPLAY  THE  CURRENT  SLOPE/PERCENT  PAIRS 

C DLISP  TO  ALLOW  USER  INPUT  OF  THE  SLOPE/PERCENT  PAIRS 

C DLST  TO  DISPLAY  THE  SUMMARY  TABLE  OF  VOLUMES  AND  COSTS 

C DLGCO  TO  COMPUTE  GRADING  COSTS  AND  VOLUMES  FOR  THE  OPENING  CUT 

C DLGCM  TO  COMPUTE  GRADING  COSTS  AND  VOLUMES  FOR  THE  MINE  RUN 

C DLGCF  TO  COMPUTE  GRADING  COSTS  AND  VOLUMES  FOR  THE  FINAL  CUT 

C 
C 

C DLGE  USES  THE  TCS  ROUTINES  : ERASE  AND  HOME 
C 


C LOCAL  VARIABLES  : 


C 

C "ACRES" 
C 

C "CPAC" 

C 

C "CST" 

C 

C "IANS" 

C "NUMB" 

C "PRCT" 

C "SLPE" 

C "TLSB" 


IS  THE  GRADED  AREA  FOR  A SPECIFIC  SLOPE/PERCENT 
PAIR  (IN  ACRES) 

IS  THE  COST  PER  ACRE  FOR  A SPECIFIC  SLOPE/PERCENT 
PAIR  (IN  DOLLARS/ACRE) 

IS  THE  COST  OF  GRADING  FOR  A SPECIFIC  SLOPE/PERCENT 
PAIR  (IN  DOLLARS) 

IS  THE  LOCAL  ANSWER  CELL 

IS  THE  NUMBER  OF  SLOPE/PERCENT  PAIRS  (AS  DEFINED  IN  DLISP) 
IS  THE  PERCENT  ARRAY  (AS  DEFINED  IN  DLISP) 

IS  THE  SLOPE  ARRAY  (AS  DEFINED  IN  DLISP) 

IS  THE  HYPOTHETICAL  TOTAL  LENGTH  OF  THE  MINE  RUN 
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C SPOILS  (IN  FELT) 

C "TOTCST"  IS  THE  TOTAL  COST  OF  GRADING  (IN  DOLLARS) 

C MOTOOL*  IS  THE  TOTAL  VOLUME  GRADED  (IN  CUBIC  YARDS) 

C -VOL'  IS  THE  VOLUME  GRADED  FOR  A SPECIFIC  SLOPE/PERCENT 
C PAIR  (IN  CUBIC  YARDS) 

C •WIDTH'  IS  THE  FINAL  WIDTH  OF  THE  OPENING  CUT  SPOIL  BANK  (IN  FEET) 
C 

C LABEL  COMMON  ALTRN  AND  LABEL  COMMON  TABLE  ARE  DECLARED 
C 

C DLGE  IS  SWAPPED  IN  BY  PROGRAM  DLGEX 
C 

C THIS  ROUTINE  WAS  WRITTEN  BY  GREEN 
C (PATTTERNED  AFTER  'GRADE'  BY  EASTMAN) 

C 

C CLAIM  RELEASE  1*0  - APRIL  1»  1980 

C 

C TEKTRONIX  COMMON 

C 

COMMON  ITEK  (45) 

C 

C LOGICAL  UNITS  AND  COMMON  LOCATION 

C 

COMMON  IARRY(5) y IARY2(5) yLERyLUFyLUL 
C 

C POINTERS 

C 

COMMON  EXIT  , 1ANM(3) y ICLI (2) y I6EN(3) y IGRW(5) 

COMMON  lOPTN  y lOVR ( 7 ) y IPNTR  y ISOC ( 6 ) y ISUB ( 8 ) 

COMMON  ISUR(6) y IT0P(9) y IVEG(2) y LEX IT  yLUO 
COMMON  MODE  yNANM  yNCLI  yNGEN  yNGRW 

COMMON  NOVR  yNSECTS  yNSOC  yNSUB  yNSUR 

COMMON  NTOP  yNU  yNVEG 

C 

C GRADING  PARAMETERS 

C 

COMMON  AR£A(5)  y BENLEN ( 5 y 10 ) yBENWKSylO)  y COGO y 6CPA ( 5 ) 

COMMON  GRDVBS(5) y HWH T ( 5 y 10 ) y HWSLl ( 5 y 10 ) y NSPP ( 5 ) yPCEQ19(4) 
COMMON  PERCNT(5y 10) yREHCPY(5) yREHV0L(5) y SL0PE(5y 10) y WBP 
C 

C CATEGORY  TEXT 

C 

COMMON  ANIM(23y 13) yCLMA(13y 13) y 6DES( 15y 13) y GWHY(22y 13) 

COMMON  0VBD(llyl3) ySBSL(13) y SCEC ( 33 y 1 3 ) y SWHY ( 44 y 1 3 ) 

COMMON  TPSL(49yl3) yVGTA(15y 13) 

C 

C EXPECTATION  VALUES 

C 

COMMON  ANIMAL(13y6) yCLlMAT(8y6) y GENDES ( 8 y 6 ) y GRWHYD ( 19 y 6 ) 

COMMON  0VRBDN(28y6) y SOCECN ( 29 y 6 ) y SUBSOI ( 30 y 6 ) y SURH YD ( 23 y 6 ) 
COMMON  T0PS0I(33y6) y VEGETA(10y6) 

C 

C CATEGORY  RESPONSES 

C 

COMMON  RANIMA(3) yRCLIMA(2) yRGENDE(3) yRGRWHY(5) 

COMMON  R0VRBD(7y 10) y RSOCEC ( 6 ) y RSUBSO ( 8 ) yRSURHY(6) 
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0111 

0112 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120 

0121 

0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 

0161 

0162 

0163 

0164 

0165 

0166 


COMMON  RTOPSO ( 9 ) > RVtGET ( 2 ) 


C 

C FEASI>TECON>OPUSE  SUBSYSTEM  PARAMETERS 

C 

COMMON  CAAHMyCABAH>CABFN<3) ?CABFP(3) jCABHM 

COMMON  CABS ( 2 ) y CAC  y CACP  y CADF  y CADH 

COMMON  CADS  y CAEAF  y CAHSAF  y CAHSTS  y CAIP 

COMMON  CAR3FC  y CASE  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRPyFA0G(5) yPFSTSPyPFACyRCLTEC(29y34) 

COMMON  TCAR(5) y THICK(IO) yTHKTSyTTL(40) 

C 

INTEGER  EXI T y CLMA  y GDES  y GWHY  y OVBD  y SBSL 
INTEGER  SCEC  y SWH Y y TPSL  y OGTA  y ANIM 
INTEGER  CLIMAT  y GENDES  y GRWHYD  y OMRBDN 
INTEGER  SOCECNySUBSOI ySURHYDyTOPSOl 
INTEGER  OEGETAy ANIMAL 

I NTEGER  RCL I MA  y RGENDE  y R6RWHY  y ROORBD  y RSOCEC 
INTEGER  RSUBSOyRSURHYy RTOPSO yROEGETyRANIMA 


INTEGER  RCLTECyTTL 


INTEGER  COMMON  <1) 
EQUIVALENCE  (COMMON  (l)y 


EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 


(lARRY 

(IARY2 

(IARY2 

(IARY2 

(IARY2 


(l)y 

(1) y 

(2)  y 

(3)  y 

(4)  y 


ITEK  (1)) 
LUT) 

ISTRK) 

ISECT) 

ICODE) 

LEN) 


COMMON  /TABLE/ 


TBLVy  TBLTy  TBLAy  TBLSy  JCOUNT y TSMIN y KOBE y 
TSMAXyTVMINy TVMAXyTAMINyTAMAXy TTMINy TTMAX 


DIMENSION  TBLV(12) yTBLT(12) y TBLAC12) yTBLS(12) 


C 

LOGICAL  LER 

DIMENSION  SLPE(IO) yPRCT(lO) 

C 

C VIEW  GRAPHS  OR  TABLES  ? (CRT) 

5 IF (LER)  CALL  ERASE 
IF(LER)  CALL  HOME 
WRITE(LUTy 1000) 

1000  F0RMAT(1X"SELECT  ONE  OF  THE  FOLLOWING'/ 

> IX' 1 ->  VIEW  GRAPHS  OF  THE  DRAGLINE  RELATIONSHIPS'/ 

> IX'2  ->  VIEW  TABLES  OF  THE  DRAGLINE  RELATIONSHIPS'/ 

> IX '0  ->  NONE  OF  THE  ABOVE'/ 

> IX 'ENTER  YOUR  SELECTION  ->  _') 

7 READ  ( LUT  yJ<«)  IANS 

IFdANS^EQ.O)  GOTO  25 

lF(LER*ANDdANS*6E*l*ANlUlANS*LE\2)  GOTO  20 
1F( ♦N0T*LER*AND*IANS*EQ*2)  GOTO  20 
WRITE(LUTy 1010) 

1010  FORMAT (/5X'ERR0R->  ILLEGAL  ENTRY*  RE-INPUT  ->  _') 

GOTO  7 

C SCHEDULE  THE  DRAGLINE  RELATIONSHIP  EXECUTIVE 

20  IPNTR=IANS 
CALL  DLRLE 


\ 
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0167 

0168 

0169 

0170 

0171 

0172 

0173 

0174 

017t5 

0176 

0177 

0178 

0179 

0180 

0181 

0182 

0183 

0184 

0185 

0186 

0187 

0188 

0189 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

0197 

0198 

0199 

0200 

0201 

0202 

0203 

0204 

0205 

0206 

0207 

0208 

0209 

0210 

0211 

0212 

0213 

0214 

0215 

0216 

0217 

0218 

0219 

0220 

0221 

V Am.  Am.  Am, 


IF<IPNTR»NE»3)  GOTO  5 
C GRADE  SPOILS  ONLY  OPTION  ? 

25  IF(M0DE*NE»4)  GOTO  49 

C INPUT  SLOPES  AND  PERCENTS  FOR  GRADE  SPOILS  ONLY 

27  CALL  DLISP(PRCT,SLPE>NUMB) 

DO  30  K=lyNUMB 

SLOPEd  jK)=SLPE<K) 

30  PERCNT ( 1 y K ) =PRCT  < K ) 

LU0=1 

NSPP(1)=NUMD 
CALL  DLST 
RETURN 

C READ  THE  RECOMMENDATIONS  FOR  FINAL  TOPOGRAPHY 

49  K0DE=1 

IF ( MODE ♦ EQ ♦ 2 ♦ AND ♦ I OPTN ♦ NE . 1 ) GOTO  50 
WRITE (LUTy 99) 

99  FORMAT  <///dX*ONE  MOMENT?  PLEASE ^ ) 

CALL  DLRSL 

IF(EXIT»EQ*-1)  STOP  1 

C DISPLAY  THE  CURRENT  SLOPE/PERCENT  PAIRS  AND  ALLOW 

C USE  MODIFICATION  TO  THEM 

50  CALL  DLDCS 

C FIGURE  THE  PERCENTAGE  OF  THE  AREA  EQUAL  TO  19  DEGREES 

DO  55  J = 2?  5 

PCEQ19(J-1)  = 0* 

DO  54  I = 1?  NSPP(J) 

IF(SLOPE( J? I ) ♦LT. 19)  GOTO  54 
PCEQ19<J-1)  = PCEQ19(J-1)  -f  PERCNT  (J?I)  / 100<. 

54  CONTINUE 

55  CONTINUE 

C COMPUTE  GRADING  COSTS 

G0T0(60?100?150)  R6ENDE<2) 

C OPENING  CUT  OPTION  

60  DO  70  J=l?5 
TOTVOL  =0. 

TOTCST  = 0* 

ACRES  = 0* 

AREA(J)  = 0< 

IF(NSPP( J) *EQ*0)  65?  67 
65  GCPA(J)  = 0. 

GOTO  70 

67  DO  69  1=1?  NSPP(J) 

CALL  DLGCO  < SLOPE  < J ? I ) ? PERCNT  < J ? I ) ? VOL  ? CST  ? CPAC  ? GRDVBS  ? 

COGO? WIDTH) 

TOTVOL  = TOTVOL  + VOL 
TOTCST  = TOTCST  + CST 
ACRES  = CST/CPAC 
AREA(J)  = AREA<J)  + ACRES 

69  CONTINUE 

GCPA(J)  = TOTCST  / AREA(J) 

70  CONTINUE 
GOTO  500 


C MINE  RUN  OPTION 

100  DO  120  J = 1?5 
TOTVOL  = 0* 

TOTCST  = 0* 


no 


0223 

0224 

0225 

0226 

0227 

0228 

0229 

0230 

0231 

0232 

0233 

0234 

0235 

0236 

0237 

0238 

0239 
'0240 

0241 

0242 

0243 

0244 

0245 

0246 

0247 

0248 

0249 

0250 

0251 

0252 

0253 

0254 


DO  110  1 = 1>  NSPP(J) 

CALL  ULGCM ( SLOPE ( J y I ) , PERCNT ( J y I ) y OOL  y CST  y TLSB  y GRDOBS  y COGO ) 
TOTOOL  = TOTOOL  + UOL 
TOTCST  = TOTCST  -I-  CST 

ACRES  =<(TLSB  t PERCNT  ( J y I) /lOO  . ) 5^*  ( 6RD0BS  ( 1 ) /3  ♦ ) ) / 4840* 
CPAC  = CST/ACRES 
110  CONTINUE 


GCPACJ)  = TOTCST  / GRD0BS<3) 

120  AREA(J)  =••  6RD0BS(3) 

GOTO  500 

C FINAL  CUT  OPTION 

150  DO  170  J = ly  5 
TOTOOL  = 0. 

TOTCST  = 0* 

AREA(J)  = 0* 


IF(NSPP< J) *EQ*0)  151y  152 

151  GCPA(J)  = 0* 

GOTO  170 

152  DO  160  I = ly  NSPP(J) 

CALL  DLGCF ( SLOPE  < J y I ) y PERCNT ( J y I ) y UBP  y 6RDUBS  y 
* COGO  y VOL  y CST  y ACRES ) 

TOTVOL  = TOTVOL  + VOL 
TOTCST  = TOTCST  + CST 
AREA(J)  = AREA<J)  + ACRES 
160  CPAC  = CST  / ACRES 

6CPA(J)  = TOTCST  / AREA(J) 

170  CONTINUE 

C OFFER  SUMMARY  TABLES 

500  CALL  DLST 
RETURN 
END 

ENM. 
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&DLIOF  T=00004  IS  ON  CR00015  USING  00020  BLKS  R=0000 


0001  FTN4 

0002 


SUBROUTINE  DLIOF 

DRAGLINE  : INPUT  RECOMMENDED  SLOPES  AND  PERCENIS 
(OPENING  AND  FINAL  CUT  OPTIONS) 


0003  C 

0004  C 

0005  C 


0006  C LEVEL  4 

0007  C 

0008  C DLIOF  IS  ACCESSED  BY  DLRSL  TO  READ  THE  RECOMMENDED 

0009  C SLOPE/PERCENT  PAIRS  FOR  THE  OPENING  AND  FINAL  CUT* 

0010  C 

0011  C THE  CALLING  SEQUENCE  IS  I CALL  DLIOF 

0012  C 

0013  C DLIOF  USES  THE  SYSTEM  ROUTINE  'SPOLU"  TO  ACCESS  THE  DATA 

0014  C FILE  “DLRSOF** 

0015  C 

0016  C ‘FILID*  IS  THE  ARRAY  CONTAINING  THE  THREE  WORD  ID  SEGMENT 

0017  C OF  THE  FILE  ‘DLRSOF“* 

0018  C 

0019  C ‘EXIT"  IS  SET  TO  -1  IF  THE  FILE  ACCESS  FAILS 

0020  C 

0021  C THIS  ROUTINE  WAS  WRITTEN  BY  GREEN 

0022  C 

0023  C CLAIM  RELEASE  1*0  - APRIL  1»  1980 


0025  C 

0026  C 

0027  C 

0028 


COMMON  ITEK  (45) 


TEKTRONIX  COMMON 


0029  C 

0030  C 

0031  C 

0032 


LOGICAL  UNITS  AND  COMMON  LOCATION 


COMMON  IARRY(5) j I ARY2 ( 5 ) » LER y LUF , LUL 


0033  C 

0034  C 

0035  C 

0036 


POINTERS 


COMMON  EXIT  y I ANM ( 3 ) y ICLI < 2 ) » IGEN ( 3 ) y IGRW < 5 ) 

COMMON  lOPTN  y I0VR(7) y IPNTR  y ISOC ( 6 ) y ISUB ( 8 ) 


0037 

0038 

0039 

0040 

0041 


COMMON  ISUR(6) y IT0P(9) y 1 VEG ( 2 ) y LEXIT  yLUO 
COMMON  MODE  yNANM  yNCLI  yNGEN  yNGRW 

COMMON  NOVR  yNSECTS  yNSOC  yNSUB  yNSUR 

COMMON  NTOP  yNU  yNVEG 


0042  C 

0043  C 

0044  C 

0045 


GRADING  PARAMETERS 


0046 

0047 


0048  C 

0049  C 

0050  C 

0051 


CATEGORY  TEXT 
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0055  C 

0056  C 

0057 

0058 

0059 

0060  C 

0061  C 

0062  C 

0063 

0064 

0065 

0066  C 

0067  C 

0068  C 

0069 

0070 

0071 

0072 

0073 

0074 

0075  C 

0076 

0077 

0078 

0079 

0080 
0081 
0082 

0083 

0084  C 

0085 

0086 

0087 

0088 

0089 

0090 

0091 

0092  C 

0093 

0094 

0095 

0096 

0097  C 

0098  C 

0099 

0100 
0101 
0102 

0103 

0104 

0105 

0106  C 

0107 

0108 

0109  C 

0110 


EXPECTATION  VALUES 

COHhON  ANIMAL<13>6) yCLlMAT(8»6) yGENHES(8,6) y 6RWHYD ( 1 9 y 6 ) 
COMMON  0VRBDN(28r6) ?S0CECN(2996) ,SUBS0I(30»6) >BURHYD(23»6) 
COMMON  T0PS0I(33»6) » VEGETA < 10 » 6 ) 

CATEGORY  RESPONSES 

COMMON  RANIMA(3) ?RCLIMA(2) ?RGENDE(3) yRGRWHY<5) 

COMMON  R0VRBD<7? 10) »RS0CEC(6) » RSUBSO ( 8 ) y RSURHY < 6 ) 

COMMON  RTOPSO ( 9 ) y RVEGET ( 2 ) 

FEASIyTECONyOPUSE  SUBSYSTEM  PARAMETERS 

COMMON  CAAHMyCABAHyCABFN(3) yCABFP<3) yCABHM 

COMMON  CABS ( 2 ) y CAC  y C ACP  y C ABF  y CADH 

COMMON  CADS  y CAEAF  y CAHSAF  y CAHSTS  y CAIP 

COMMON  CAR3FC  y CASE  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y FAV6  < 5 ) y PFSTSP  y PFAC  y RCLTEC ( 29  y 34 ) 

COMMON  TCAR(5) y THICK(IO) y THKTSyTTL(40) 


INTEGER  EXI T y CLMA  y GDES  y 6WHY  y OVBD  y SBSL 
INTEGER  SCEC  y SUHY  y TPSL  y VGTA  y ANIM 
INTEGER  CLIMATyGENDESy GRUHYDyOVRBDN 
INTEGER  SOCECNySUBSOI y SURHYDy TOPSOI 
INTEGER  VEGE7 Ay  ANIMAL 

I NTEGER  RCL 1 MA  y RGENDE  y RGRWHY  y ROVRBD  y RSOCEC 
INTEGER  RSUBSO  y RSURH Y y RTOPSO  y RVEGET  y RANIMA 
INTEGER  RCLTEC yTTL 


INTEGER  COMMON  (1) 


EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 


(COMMON  (1) 
(lARRY  <l)y 
(IARY2  <l)y 
(IARY2  (2)y 
(1ARY2  (3)y 
(IARY2  (4)y 


II EK  (1)) 
LUT) 

ISTRK) 

ISECT) 

I CODE) 

LEN) 


LOGICAL  LER 
INTEGER  FILID(3) 

DATA  FILID/2HDLy2HRSy2H0F/ 
DATA  ICR/15/ 


RE-INITIALIZE  THE  SLOPES  AND  PERCENTS 

DO  2 I = ly  5 
NSPP  (I)  = 0 
DO  1 J = lylO 
SLOPE  (lyJ)  = 0< 

PERCNT  (lyJ)  = 0* 

1 CONTINUE 

2 CONTINUE 

OPEN  DLRSOF  FOR  READ 
CALL  SP0LU(LUFyFILIDy2y 1 y ICR) 

IF(LUF»LT«0)  GOTO  500 

RE-:AD  THE  NUMBER  OF  PERCENT  PAIRS  IN  EACH  ALTERNATIVE 
DO  10  I=ly5 
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0111 

10 

READ(LUF,1000)  NSPf’(I) 

0112 

1000 

F0RMAT(I2) 

0113 

C 

NOW  REAii  IN  THE  PERCENTAGES 

0114 

DO  20  1=1 y 5 

0113 

> 

IF(NSPPd)  ♦EQ.O)  GOTO  20 

0116 

DO  15  J=lyNSPP<I) 

0117 

15 

READ ( LUF ,1010)  PERCNT ( I , J ) 

0118 

1010 

F0RMAT<F5.1) 

0119 

20 

CONTINUE 

0120 

C 

NOW  READ  IN  THE  SLOPES 

0121 

DO  35  1=1,5 

0122 

IF(NSPP(I) .EQ»0)  GOTO  35 

0123 

DO  30  J=l,NSPPa) 

0124 

30 

READ(LUF, 1010)  SLOPE(IyJ) 

0125 

35 

CONTINUE 

0126 

C 

tt  ALL  DONE*  tt  CLOSE  FILE* 

0127 

CALL  SP0LU(LUF,FILID,2,2,ICR) 

0128 

RETURN 

0129 

C 

ERROR  ON  OPEN  t GIOE  MESSAGE 

0130 

500 

WRITE <6, 1020)  LUF 

0131 

1020 

F0RHAT(1H1,10X'ERR0R  ON  OPEN  RSPOF*  LUF  = 

0132 

EXIT  = -1 

0133 

RETURN 

0134 

END 

0135 
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&DLIRM  1==00004  IS  ON  CR00015  USING  00019  BLKS  R=0000 


0001  FTN4 

0002 

0003  C 

0004  C 


SUBROUTINE  DLIRM 

— DRAGLINE  : INPUT  RECOMMENDED  SLOPES  (MINE  RUN) 


0005  C LEVEL  4 

0006  C 

0007  C DLIRM  IS  ACCESSED  BY  DLRSL  TO  READ  THE  RECOMMENDED  FINAL 

0008  C SLOPES  AND  PERCENTS  FOR  THE  MINE  RUN  OPTION 

0009  C 

0010  C THE  CALLING  SEQUENCE  IS  I CALL  DLIRM 

0011  C 

0012  C DLIRM  USES  THE  SYSTEM  ROUTINE  “SPOLU"  TO  ACCESS  THE  DATA 

0013  C FILE  "DLRSPM* 

0014  C 

0015  C *FIL1D‘  IS  THE  ARRAY  CONTAINING  THE  ID  SEGMENT  OF  THE 

0016  C FILE  'DLRSPM** 

0017  C 

0018  C “EXIT-  IS  SET  TO  -1  IF  THE  FILE  ACCESS  FAILS 

0019  C 

0020  C THIS  ROUTINE  HAS  WRITTEN  BY  GREEN 

0021  C 

0022  C CLAIM  RELEASE  1*0  - APRIL  1,  1980 


0024  C 

0025  C 

0026  C 

0027 


COMMON  ITEK  (45) 


TEKTRONIX  COMMON 


0028  C 

0029  C 

0030  C 

0031 


COMMON  1ARRY<5)  y I ARY2  ( 5 ) y LER  y LUF  y LUI. 


LOGICAL  UNITS  AND  COMMON  LOCATION 


0032  C 

0033  C 

0034  C 

0035 


POINTERS 


COMMON  EXIT  y 1ANM(3) y ICLI (2) y 1GEN(3) y IGRU<5) 
COMMON  lOPTN  y IGVR(7) y IPNTR  y I SOC ( 6 ) y ISUB ( 8 ) 


0036 

0037 

0038 

0039 

0040 


COMMON  ISUR<6) y IT0P(9) y IVEG<2) yLEXIT  yLUO 
COMMON  MODE  yNANM  yNCLl  yNGEN  yNGRW 

COMMON  NOVR  yNSECTS  yNSOC  yNSUB  yNSUR 

COMMON  NTOP  yNU  yNVEG 


0041  C 

0042  C 

0043  C 

0044 


GRADING  PARAMETERS 


0045 

0046 


0047  C 

0048  C 

0049  C 

0050 


CATEGORY  TEXT 


0053  C 

0054  C 


EXPECTATION  VALUES 
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0055 

0056 

0057 

0058 

0059 

0060 

0061 

0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 

0081 

0082 

0083 

0084 

0085 

0086 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 

0101 

0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


C 


C 

C 


C 


C 

C 

c 


c 


c 


c 

c 

c 


c 


COMMON  ANIMAL(13j6) yCLIMAT(8,6) »GENDES(8,6) j ORWHYD ( 19 y 6 ) 
COMMON  00RBDN<28y6) y SOCECN ( 29 y 6 ) y BUBSOI ( 30 y 6 ) y SURHYD ( 23 y 6 ) 
COMMON  TOPSOI (33y6) y VEGETA< lOy 6 ) 

CATEGORY  RESPONSES.  , 

COMMON  RANIMA(3) yRCLIMA(2) y RGENDE ( 3 ) y RGRWHY < 5 ) 

COMMON  R00RBD(7y 10) yRS0CEC(6) y RSUBSO ( 8 ) y RSURHY < 6 ) 

COMMON  RT0PS0(9) yR0EGET<2) 

FEASIy  TECONyOPLISE  SUBSYSTEM  PARAMETERS 

COMMON  CAAHM  y CABAN  y CABFN ( 3 ) y CABFP ( 3 ) y CABHM 

COMMON  CABS ( 2 ) y CAC  y CACP  y CADF  y CADH 

COMMON  CADS  y CAEAF  y CAHSAF  y CAHSTS  y CAIP 

COMMON  CAR3F  C y CASF  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y FAOG ( 5 ) y PFSTSP  y PFAC  y RCLTEC ( 29  y 34 ) 

COMMON  TCAR<5) y THICK (10) y THKTS y TTL ( 40 ) 

INTEGER  EX I T y CLMA  y GBES  y GWH Y y OOBD  y SBSL 
I NTE6ER  SCEC  y SWH Y y TPSL  y U6TA  y AN I M 
INTEGER  CLIMATyGENDESy GRWHYDyOORBDN 
INTEGER  SOCECNySUBSOI ySURHYDy TOPSOI 
INTEGER  VEGEI AyANIMAL 

INTEGER  RCL I MA  y RGENDE  y RGRWHY  y ROURBD  y RSOCEC 
INTEGER  RSUBSO yRSURHYyRTOPSOyROEGETyRANIMA 
INTEGER  RCLTEC y TTL 

INTEGER  COMMON  (1) 

EQUIVALENCE  (COMMON  (l)y  ITEK  (1)) 

EQUIVALENCE  (lARRY  (l)y  LUT) 

EQUIVALENCE  ( IARY2  (l)y  ISTRK) 

EQUIVALENCE  (IARY2  (2)y  ISECT) 

EQUIVALENCE  (1ARY2  (3)y  ICODE) 

EQUIVALENCE  (IARY2  (4)y  LEN) 

LOGICAL  LER 

INTEGER  FILID  (3) 


DATA  FILlD/2HDLy2HRSy2HPM/ 
DATA  ICR/15/ 


C THE  MINIMUM  FINAL  SLOPE  CAN  BE  NO  GREATER  THAN  THE 

C INITIAL  SLOPE  OF  THE  AREA.  THEREFORE y WE  DEFINE 

C THESE  SLOPES  HEREy  RATHER  THAN  IN  DLRSPM 

DO  10  1=1 y 5 

10  SLOPE(Iyl)  = GRDVBS(4) 

C OPEN  DLRSPM  FOR  READ  t 

CALL  SP0LU(LUFyFILIDy2y 1 y ICR) 

IF(LUF.LT.O)  GOTO  500 

C READ  IN  THE  NUMBER  OF  PERCENT  PAIRS  FOR  EACH  ALTERNATIVE 

DO  15  1=1 y 5 

15  READ (LUFy 1000)  NSPP(I) 

1000  F0RMAT(I2) 
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0111 

0112 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120 

0121 

0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 


C NOW  READ  IN  THE  PERCENTAGES 

DO  25  1=1j5 
DO  20  J=1>NSPP(1) 

20  READ<LUF» 1010)  PERCNT(I>J) 

1010  P0RHAT(F5*1) 

25  CONTINUE 

C NOW  READ  IN  THE  SLOPES 

DO  35  1=1 j 5 
DO  30  J=2yNSPP<I) 

30  READ(LUFj  1010)  SLOPEdjJ) 

35  CONTINUE 

C m ALL  DONE  CLOSE  THE  FILE* 

CALL  SP0LU(LUFyFILIDj2»2j ICR) 

RETURN 

C ERROR  ON  OPEN  : GIUE  MESSAGE 
500  WRITE (6 y 1020)  LUF 

1020  FORMATdHl  jIOX'ERROR  ON  OPEN  DLRSPM*  LUF 
EXIT  = -1 
RETURN 
END 

END$ 


F13*5) 
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?«DLISP 


1=00004  IS  UN  CR00015  USING  00035  BLKS  R=0000 


0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 
0011 
0012 


0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 

0053 

0054 


FTN4 

SUBROUTINt:  DLISP  ( PF;:CT  > SLPE  y NUMB ) 

C BRAGLINt:  : INPUT  SLOPES  AND  PERCENTS 

C 

C LEVEL  4 
C 

C DLISP  IS  ACCESSED  DLGE  AND  DLDCS  TO  ALLOW  USER  DEFINITION 
C OF  THE  DRAGLINE  SLOPE/PERCENT  PAIRS 
C 

C THE  CALLING  SEQUENCE  IS  : 

C 


C 

C 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


c 

c 

c 

c 

c 


CALL  DLISP  (PRCT,SLPE,NUMB) 

WHERE 

PRCT  IS  THE  PERCENT  ARRAY  FOR  CURRENT  LUO 

SLPE  IS  THE  SLOPE  ARRAY  FOR  CURRENT  LUO 

NUMB  IS  I HE  NUMBER  OF  SLOPE/PERCENT  PAIRS  ENTERED 


DLISP  SCHEDULES  MNMXF  TO  DETERMINE  THE  MINIMUM  AND 
MAXIMUM  FINAL  SLOPE  VALUES  CURRENTLY  PERMITTED 

DLISP  USES  THE  TCS  ROUTINES  : ERASE  AND  HOME 
AND  DECLARES  LABEL  COMMON  ALTRN 

THE  LOCAL  VARIABLES  ARE  I 

CLLMIT  -'•>  CROPLAND  LIMIT 

IANS  ANSWER  CELL 

IPTR  ->  INDEX  TO  IREC  ARRAY 

IREC  -’>  ARRAY  CONTAINING  RECOMMENDED  PERCENTAGE  MIXTURES 

FOR  THE  MINE  RUN  OPTION 

IRECl  '•>  ARRAY  CONTAINING  RECOMMENDED  PERCENTAGE  MIXTURES 
FOR  THE  OPENING  AND  FINAL  CUT  OPTIONS  (NAT*  VEG.) 

IREC2  '->  ARRAY  CONTAINING  RECOMMENDED  PERCENTAGE  MIXTURES 

FOR  THE  OPENING  AND  FINAL  CUT  OPTIONS  (WLIFE  S WAT  REC) 
SLMIN  MINIMUM  PERMISSABLE  FINAL  SLOPE  VALUE 

TOTPCT'->  CUMULATIVE  PERCENTAGE 

UPLIM  «->  UPPER  LIMIT  FOR  FINAL  SLOPE  VALUE 

THIS  ROUTINE  WAS  WRITTEN  BY  GREEN 

CLAIM  RELEASE  1*0  - APRIL  1,  1980 


TEKTRONIX  COMMON 
COMMON  ITEK  (45) 

LOGICAL  UNITS  AND  COMMON  LOCATION 
COMMON  IARRY(5) y IARY2(5) y LERyLUFyLUL 
POINTERS 
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0055  C 

0056 

0057 

0058 

0059 

0060 
0061 

0062  C 

0063  C 

0064  C 

0065 

0066 

0067 

0068  C 

0069  C 

0070  C 

0071 

0072 

0073 

0074  C 

0075  C 

0076  C 

0077 

0078 

0079 

0080  C 

0081  C 

0082  C 

0083 

0084 

0085 

0086  C 

0087  C 

0088  C 

0089 

0090 

0091 

0092 

0093 

0094 

0095  C 

0096 

0097 

0098 

0099 

0100 
0101 
0102 

0103 

0104  C 

0105 

0106 

0107 

0108 

0109 

0110 


COMMON  EXIT  y IANM(3) ? ICLl (2) » I6EN(3) r I6RW(5) 

COMMON  lOPTN  ^ I0MR(7) y IPNTR  » IS0C<6) > ISUB(8) 

COMMON  ISUF<<6)  »IT0P(9)  ,I0EG(2)  jLEXIT  jLUO 

COMMON  MODE  fNANM  jNCLI  >N6EN  »N6RW 

COMMON  NOOR  ^NSECTS  yNSOC  jNSUB  »NSUR 

COMMON  NTOP  >NU  »NVEG 

GRADING  PARAMETERS 

COMMON  AREA<5)  > EENLEN ( 5 > 10 ) >BENWK5?10)  y COGO  y GCPA  ( 5 ) 

COMMON  GRD0BS(5) yHWHT(5y 10) yHWSLKSy 10) yNSPP(5) yPCEQ19(4) 
COMMON  PERCNf ( 5 y 10 ) y REHCPY ( 5 ) y REHVOL ( 5 ) y SLOPE ( 5 y 10 ) y WBP 

CATEGORY  TEXT 

COMMON  ANIM(23y 13) y CLMA ( 1 3 y 1 3 ) y 6DES ( 1 5 y 1 3 ) yGWHY(22y 13) 
COMMON  00BD(llyl3) ySBSL(13) y SCEC ( 33 y 1 3 ) y SWH Y ( 44 y 1 3 ) 

COMMON  TPSL(49y  13)  yOGTAdSy  13) 

EXPECTATION  VALUES 

COMMON  ANIMAL(13y6) yCLIMAT(8y6) y GENDES ( 8 y 6 ) y GRUH YD ( 1 9 y 6 ) 
COMMON  0VRBDN(2By6) y SOCECN ( 29 y 6 ) y SUBSOI ( 30 y 6 ) y SURHYD ( 23 y 6 ) 
COMMON  T0PS0I(33y6) yVEGETA(10y6) 


CATEGORY  RESPONSES 


COMMON  RANIMA(3)  y RCLIMA ( 2 ) y RGENDE ( 3 ) y RGRkM~{Y ( 5 ) 
COMMON  R0MRBD(7y 10) y RSOCEC ( 6 ) y RSUBSO < 8 ) y RSURHY ( 6 ) 
COMMON  RT0PS0<9) yRVEGET(2) 

FEASIyTECONyOPUSE  SUBSYSTEM  PARAMETERS 

COMMON  CAAHMyCABAHyCABFN(3) yCABFP(3) yCABHM 

COMMON  CABS ( 2 ) y CAC  y CACP  y CADF  y CADH 

COMMON  CADS  y C AEAF  y CAHSAF  y CAHSTS  y CAI P 

COMMON  CAR3FC  y CASE  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y F AVG ( 5 ) y PFSTSP  y PFAC  y RCLTEC  < 29  y 34 ) 

COMMON  TCAR(5) y THICK (10) y THKTS y TTL < 40 ) 


INTEGER  EXI T y CLMA  y GDES  y 6WHY  y OVBD  y SBSL 
INTEGER  SCECy SWHYy TPSLy VGTAy ANIM 
INTEGER  CLIMATyGENDESyGRWHYDyOVRBDN 
INT  EGER  SOCECN  y SUBSOI y SURHYD  y TOPSOI 
INTEGER  VEGETA y ANIMAL 

I NTEGER  RCL I MA  y RGENDE  y RGRWHY  y ROVRBD  y RSOCEC 
INTEGER  RSUBSO  y RSURHY  y RTOPSO  y RVEGET  y RANIMA 
INTEGER  RCLTEC y TTL 


INTEGER  COMMON  (1) 
EQUIVALENCE  (COMMON 
EQUIVALENCE  (lARRY 
EQUIVALENCE  (IARY2 
EQUIVALENCE  (1ARY2 
EQUIVALENCE  (IARY2 


(1) 
(1)  y 

(1)  y 

(2)  y 

(3)  y 


y ITEK  (1)) 
LUT) 

ISTRK) 

I SECT) 

I CODE) 
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0111 

0112 

0113 

0114 

011'5 

0116 

0117 

0118 

0119 

0120 

0121 

0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 

0161 

0162 

0163 

0164 

0165 

0166 


EQUIOALENCE  (1ARY2  <4)»  LEN) 

C 

LOGICAL  LER 
C 

DIMENSION  F'RCTdO)  »SLPE(10) 

C 

INTEGER  ALTN(6»4) 

C 

COMMON  / ALTRN  / ALIN 
C 

INTEGER  IREC(4»3)y  1REC1(3)»  IREC2(2»2) 

DATA  IREC/50 » 35 » 50 » 75  ? 25 » 40  y 1 0 t 25  y 
25y25y40y0/ 

DATA  IRECl/50y 25y25/ 

DATA  IREC2/50y 75y50y25/ 

DATA  CLLMIT/5*7/ 

C 

C SET  UPPER  AND  LOWER  LIMITS 

KC0DE=2 

CALL  MNMXE ( LUT  y MODE  y RGENDE ( 2 ) y GRDOBS  y UPL I M y SLM I N y KCODE ) 
IF(KC0DE*NE*3)  GOTO  3 
IF(M0DE*EQ*4)  GOTO  3 
WRITE ( LUT y 37) 

37  F0RMAT(/5X*DUE  TO  THE  INITIAL  GEOMEIRY  AND/OR  CUT  OPTION*/ 
> 5X*0THER  FINAL  SLOPES  VALUES  CANNOT  BE  ENTERED*) 

RETURN 

3 1F(UPLIM*LT* 19* ) KC0DE=1 

IF ( MODE ♦ NE ♦ 4 » AND ♦ LUO ♦ EQ ♦ 1 ) UPLIM=CLLMIT 
C DISPLAY  INSTRUCTIONS 

5 IF(LER)  CALL  ERASE 
IF(LER)  CALL  HOME 

IF(M0DE*NE*4)  WRITE  < LUT  y 1000)  (ALTN(LLiOy  J)  y J=1  y 4) 
IF(M0DE*EQ»4)  WRl TE ( LUT y 1002 ) 

WRITECLUTy 1001 ) 

WR I T E ( LU T y 1 020 ) UPL I M y SL M I N 
C DISPLAY  RECOMMENDATIONS 

IF(  LU0*EQ*1)  GOTO  6 
IF ( KCODE* EQ* 1 ) GOTO  6 
IF  (RGENDE  (2)  *EQ*  2)  GOTO  4 
IPTR  = LUO  - 2 

IF  (LUO  *EQ*  2)  WRITE  (LUTyl061)  IRECl 

IF  (LUO  *NE*  2)  WRITE  (LUTyl062)  (IREC2  (IPTRyJ)yJ  = ly2) 
GOTO  6 

4 -IPTR  = LUO  - 1 

WRITE  (LUfy  1060)  (IREC  (IPTRy  J)y  J = ly  3) 

C USER  INPUT  ->  SLOPE  AND  PERCENT 

6 NUMB  = 0 
TOTPCT  0* 

7 NUMB  NUMB  T 1 

1F(NUMB*GT*2*AND*LER)  CALL  ERASE 
IF(NUMB*6T*2*ANDa..ER)  CALL  HOME 
10  WRITE(LUTy 1030)  TOTPCT 
READ  (LUT  y-;*:)  SLPE  (NUMB) 

WRITE(LUTy 1031 ) 

READ  (LUfy  PRCT  (NUMB) 

IF  (RGENDE(2)  *EQ.  2)  GOTO  15 
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0167 

0168 

0169 

0170 

0171 

0172 

0173 

0174 

0175 

0176 

0177 

0178 

0179 

0180 
0181 
0182 

0183 

0184 

0185 

0186 

0187 

0188 

0189 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

0197 

0198 

0199 

0200 
0201 
0202 

0203 

0204 

0205 

0206 

0207 

0208 

0209 

0210 
0211 
0212 

0213 

0214 

0215 

0216 

0217 

0218 

0219 

0220 
0221 
0222 


IK  (SLPE  (NUM8) ♦GE^SLMIN* AND^SLPE  (NUHB) ♦LE*UPLIM)  GOTO  20 
URITE(LUT> 1040) 

GOTO  10 

15  IF  (SLPE  (HUMIO  ♦GE\SLMIN.AND*SLPE  < NUHB ) ♦ LE . UPLIM ) GOTO  20 
WRITE(LUT»1040) 

GOTO  10 

20  TOTPCT  = TOTPCT  + PRCT  (NUMB) 

IFCTOTPCT  *EQ*  100* ) RETURN 
IFCTOTPCT  ♦GT*  100*  ) 30>  7 
C OOPS  ! PERCENTAGE  > 100  I INFORM  USER 

30  WRITE  (LUTjIOSO) 

31  READ  (LUTj  :♦:)  IANS 

IF<IANS*GE*1*AND*IANS»LE*2)  GOTO  (5»35)  IANS 
WRITE(LUTr 1111) 

GOTO  31 

35  TOTPCT  = TOTPCT  - PRCT  (NUMB) 

PRCT  (NUMB)  = 0* 

SLPE  (NUMB)  = 0* 

GOTO  10 

C FORMAT  STATEMENTS 

1000  F0RMAT(/,5X*READY  TO  ACCEPT  SLOPE/PERCENT  PAIRS  FOR  MA2) 

C 

1001  FORMAT ( 

>/»3X'>  INPUT  SLOPED  HIT  RETURN^  THEN  INPUT  PERCENT  OF  THE*/ 
&3X*  AREA  YOU  WANT  COUERED  BY  THAT  SLOPE* */» 

S/?3X'>  10  SLOPE  / PERCENT  PAIRS  ARE  ALLOWED* V) 

C 

1002  FORMAT  (15X“  i^)K  INPUT  FINAL  SLOPES  - GRADE  RUN  tf) 

1010  F0RMAT(/,5X*RESTRICTI0NS  f/? 

S3X*>  FINAL  SLOPE  REQUESTED  MUST  NOT  EXCEED  19  DEGREES V/> 
S3X'>  FINAL  SLOPE  MUST  BE  AT  LEAST  11*5  DEGREES* /t 
S3X*>  TOTAL  PERCENTAGE  MUST  EQUAL  100**) 

C 

1111  FORMAT  (/,5X*5«:-4cERROR-4c:^*  ANSWER  MUST  BE  1 OR  2*  RE-ENTER  ->_*) 
1020  FORM  AT  (/,5X*  RESTRICT  IONS  IW/, 

S3X*>  FINAL  SLOPE  MUST  NOT  EXCEED  •F4*2"  DEGREES*/? 

S3X*>  FINAL  SLOPE  MUST  BE  AT  LEAST  *F5*2*  DEGREES*/? 

&3X*>  TOTAL  PERCENTAGE  MUST  EQUAL  100*) 

C 

1060  FORMAT (//?5X*WE  RECOMMEND  THE  FOLLOWING  RANGE  OF  SLOPES:*/? 

+ 5X?I2*%  LESS  THAN  OR  EQUAL  TO  5*7  DEGREES*/? 

+ 5X?I2*%  GREATER  THAN  5*7  AND  LESS  THAN  OR  EQUAL*/? 

+ 7X*T0  11*5  DEGREES*/? 

+ 5X?I2*%  GREATER  THAN  11*5  AND  LESS  THAN  OR  EQUAL  */? 

■f  7X*T0  19  DEGREES*) 

1061  F0RMAT(//?5X-UE  RECOMMEND  THE  FOLLOWING  RANGE  OF  SLOPES:*/? 
T5X?I2*%  GREATER  THAN  OR  EQUAL  TO  11*5?  AND  LESS*/? 

+5X*THAN  14  DEGREES*/? 

+ 5X?I2*%  GREATER  THAN  OR  EQUAL  TO  14?  AND  LESS  */ 

+5X*THAN  17  DEGREES*/? 

+5X?I2*X  GREATER  THAN  OR  EQUAL  TO  17?  AND  LESS  */? 

+5X*THAN  19  DEGREES*//) 

C 

1062  F0RMAT(//?5X*WE  RECOMMEND  THE  FOLLOWING  RANGE  OF  SLOPES:*/? 
+5X?I2*%  GREATER  OR  EQUAL  TO  11*5?  AND  LESS  */? 

+5X*THAN  15  DEGREES*/? 
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0223 

0224 

0225 

0226 

0227 

0228 

0229 

0230 

0231 

0232 

0233 

0234 

0235 

0236 

0237 

0238 


+5XfI2*%  GREATER  THAN  OR  EQUAL  TO  15?  AND  LESS  V? 

+5X'THAN  19  DEGREES-//) 

C 

1030  F0RMAT(/?5)C-CURRENT  PERCENTAGE  DEFINED  IS  :-F6*2*  %"/ 

5X- INPUT  SLOPE  -> 

1031  F0RMAT(5X-INPUT  PERCENT  ->  _-) 

C 

1040  F0RHAT(/?5X-ERR0R  ->  SLOPE  DOES  NOT  MEET  RESTRICTIONS*  RE-INPUf) 
C 

1050  F0RMAT(/?5X-T0TAL  PERCENTAGE  EXCEEDS  100*  '/ 

> 5X-1  “>  START  OUER-/ 

> 5X-2  ->  RE-INPUT  SLOPE/PERCENT  PAIR-/ 

> 5X- INPUT  ->  _•) 

C 

END 

END$ 
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SDLMID  T=00004  IS  ON  CR00015  USING  00029  BLKS  R=0000 


0001  FTN4 

0002 
0003  C 


, SUBROUTINE  DLMID 
DRAGLINE  : NINE  RUN  INITIAL  DATA 


0004  C 

0005  C LEVEL  2 

0006  C 

0007  C DLHID  IS  ACCESSED  BY  GDE  TO  SCHEDULE  INPUTS  AND  EDITS  TO 

OOOG  C THE  INITIAL  DATA  FOR  THE  DRAGLINE/HINE  RUN  OPTION 

0009  C 

0010  C “lOPTN’  IS  A SUITCH  WHERE  J 

0011  C 1 " INPUT  NODE 

0012  C 2 - EDIT  NODE 

0013  C 3 - TEMPORARY  EDIT  NODE 

0014  C 

0015  C THE  CALLING  SEOUENCE  IS  : CALL  DLNID 

0016  C 

0017  C DLNID  USES  THE  TCS  ROUTINES  : ERASE  AND  HONE 

0018  C 

0019  C "1ANS“  IS  THE  LOCAL  ANSWER  CELL 

0020  C 

0021  C THIS  ROUTINE  WAS  WRITTEN  BY  GREEN?  BUT  PATTERNED  AFTER 

0022  C A ROUTINE  WRITTEN  BY  EASTMAN*  (GRADE) 

0023  C 

0024  C CLAIM  RELEASE  1*0  - APRIL  1?  1980 


0026  C 

0027  C 

0028  C 

0029 


COMMON  ITEK  (45) 


TEKTRONIX  COMMON 


0030  C 

0031  C 

0032  C 

0033 


COMMON  IARRY(5) y IARY2(5) jLERjLUF  ?LUL 


LOGICAL  UNITS  AND  COMMON  LOCATION 


0034  C 

0035  C 

0036  C 

0037 


POINTERS 


COMMON  EXIT  ? I ANM ( 3 ) ? ICLI ( 2 ) ? I GEN ( 3 ) y IGRW ( 5 ) 

COMMON  I OPTN  ? 1 0 VR ( 7 ) ? I PNTR  y 1 SOC ( 6 ) y I SUB ( 8 ) 


0038 

0039 

0040 

0041 

0042 


COMMON  ISUR(6) y 1T0P(9) y I VEG ( 2 ) y LEXI T yLUO 
COMMON  MODE  y NANM  yNCLI  yNGEN  yNGRW 

COMMON  NOVR  yNSECTS  yNSOC  yNSUB  yNSUR 

COMMON  NTOP  y NU  yNVEG 


0043  C 

0044  C 

0045  C 

0046 


GRADING  PARAMETERS 


0047 

0048 


0049  C 

0050  C 

0051  C 

0052 


CATEGORY  TEXT 
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005ti  C 
0056  C 
005/  C 

0058 

0059 

0060 

0061  C 

0062  C 

0063  C 

0064 

0065 

0066 

0067  C 

0068  C 

0069  C 

0070 

0071 

0072 

0073 

0074 

0075 

0076  C 

0077 

0078 

0079 

0080 


EXPECTATION  VALUES 

COMMON  ANIMAL<13?6) ?CLIMAT<8y6) yGENDES(8?6) » ORWHYD ( 19 » 6 ) 
COMMON  OVRBDN ( 28  y 6 ) ? SOCECN  < 29  y 6 ) y SUBSO I ( 30  y 6 ) y SURH YD ( 23  y 6 ) 
COMMON  T0PS0I(33y6) yVEGETA(10y6) 


CATEGORY  RESPONSES 


COMMON  RANIMA<3) yRCLIMA(2) yRGENDE(3) yR6RWHY(5) 
COMMON  R0VRBD(7y 10) yRS0CEC(6) yRSUBS0<8) yRSURHY(6) 
COMMON  RT0PS0(9) yRVEGET(2) 

FEASIyTECONyOPUSE  SUBSYSTEM  PARAMETERS 


COMMON  CAAHMyCABAHyCABFN(3) yCABFP(3) yCABHM 

COMMON  CABS ( 2 ) y CAC  y CACP  y CADF  y CABH 

COMMON  CADS  y CAEAF  y CAHSAF  y CAHSTS  y CA IP 

COMMON  CAR3FC  y CASE  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y FAVG  < 5 ) y PF  STSP  y PFAC  y RCLTEC ( 29  y 34 ) 

COMMON  TCAR(5) y THICK (10) y THKTS y TTL ( 40 ) 

INTEGER  EXI T y CLMA  y GDES  y GWH Y y OVBD  y SBSL 
INTEGER  SCEC  y SWHY  y TPSL  y VGTA  y ANI M 
INTEGER  CL I MAT  y GENDES  y GRUHYD  y OVRBDN 
INTEGER  SOCECN y SUBSOI ySURHYDyTOPSOI 


0081 

0082 

0083 

0084 

0085  C 

0086 

0087 

0088 

0089 

0090 

0091 

0092 

0093  C 

0094 

0095  C 

0096 

0097 

0098 

0099 

0100  C 

0101 
0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


INTEGER  VEGETAy ANIMAL 

INTEGER  RCLIMA  y RGENDE  y RGRWHY  y ROVRBD  y RSOCEC 
INTEGER  RSUBSO  y RSURHY  y RTUPSU y RVEGET  y RANIMA 
INTEGER  RCLTEC y TTL 

INTEGER  COMMON  (1) 

EQUIVALENCE  (COMMON  (l)y  ITEK  (1)) 

EQUIVALENCE  (lARRY  (l)y  LUT) 

EQUIVALENCE  (IARY2  (l)y  ISTRK) 

EQUIVALENCE  (IARY2  (2)y  ISECT) 

EQUIVALENCE  (1ARY2  (3)y  ICODE) 

EQUIVALENCE  (IARY2  (4)y  LEN) 

LOGICAL  LER 

DISPLAY  THE  TITLE 

EXIT=i 

1 IF  (LER)  CALL  ERASE 
IF  (LER)  CALL  HOME 

WRITE  (LUTy  1000) 

DISPLAY  CURRENT  DATA  FOR  EDIT  MODE  (lOPTN  = 2) 
IF  (IOPTN*EQ.l  ) GOTO  30 

WRITE  (LUTy  1100)  (GRDVBS  (JJ)y  JJ  = ly  4)y  COGO 

2 READ  (LUIy  t ) IANS 

IF  (IANS*EQ*0)  GOTO  4 
IF  (IANS. GE.l. AND. IANS»LE«5  ) 

>GOTO  ( 30 y 40 y 50 y 60 y 70  ) IANS 
WRITE  (LUTy  1110) 

GOTO  2 

4 XF(I0PTN.EQ.3)  I0PTN=^1 
RETURN 
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0111 

0112 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120 
0121 
0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 
0161 


C USER  INPUT  ->  DISTANCE  BETWEEN  SPOIL  BANKS 

30  WRITE  (LUfy  1030) 

READ  (LUT»  t)  GRDMBS  <1) 

IF  (I0PTN*NE*1  ) GOTO  1 
IF  (GRDOBS  <1)*6E*0*)  GOTO  40 
EXIT  = 0 
RETURN 

C USER  INPUT  ->  SLOPE  OF  THE  SPOILS 

40  WRITE  (LUTy  1040) 

READ  (LUTy  GRD'v'BS  (2) 

IFdOPTN  ♦NEi.  3)  GOTO  41 

IF(GRD0BS(2) » GE ♦ GRDOBS < 4 ) ♦ AND . GRDOBS ( 2 ) *LE*90, ) GOTO  1 
WRITE(LUTy 1066) 

GOTO  40 

41  IF  ( GRDOBS  C 2 ) ♦ 6T ♦ 0 ♦ . AND < GRDMBS  (2)*LT*90) 

>GOTO  ( 50ylyl  ) lOPTN 

WRITE  (LUTy  1045) 

GOTO  40 

C USER  INPUT  ->  AREA  COVERED  BY  THE  SPOILS 

50  WRITE  (LUTy  1050) 

52  READ  (LUTy  GRDVBS  (3) 

IF(GRDVBS(3) *6T*0)  GOTO  55 
WRITE(LUTy 1075) 

GOTO  52 

55  IF  (I0PTN*NE*1  ) GOTO  1 
C USER  INPUT  ->  SLOPE  OF  THE  AREA 

60  WRITE  (LUTy  1060) 

READ  (LUTy  t)  6RDVBS  (4) 

IF  ( GRDVBS  (4)  *GE*0*  AND*  GRD'v'BS  ( 4 ) ♦ LT  ♦ GRDVBS  (2)  ) 
>60T0  65 

WRITE  (LUTy  1065) 

GOTO  60 

65  IF(GRDVBS(4) *GT*5*7)  WRI TE ( LUT y 1061 ) 

IF(GRDMBS(4) *GT*5*7)  CALL  BELL 
IF(6RD'v'BS(4)  *GT*5<  7)  CALL  TINPT(ICHAR) 

G0T0(70ylyl)  lOPTN 

C USER  INPUT  ->  COST  OF  GRADING  O'v'ERBURDEN 

70  WRITE  (LUTy  1070) 

72  READ  (LUTy  t)  COGO 

IF(COGO  *GT*  0*)  GOTO  75 
WRITE (LUTy 1075) 

GOTO  72 

75  IF  (I0PTN*NE*1  ) GOTO  1 
I0PTN=3 
GOTO  1 

C FORHAT  STATEHENTS 

1000  FORNAT(//* DRAGLINE/MINE  RUN  ‘//) 

C 


1100  F0RHAT(/y5X"CURREN T '7ALUES  FOR  THE  DATA  ARE  t“/y 
>7X“1)  A'VERAGE  DISTANCE  BETWEEN  SPOIL  BANK  PEAKS: 
>“FEET"/y 


F9*2y 


IX 


0162 

0163 

0164 

0165 

0166 


>7X*2)  INITIAL  AVERAGE  SLOPE  OF  THE  SPOIL  BANKS  :*F9*2ylXy 
>' DEGREES “/y 

>7'A^Z)  lOlAL  AREA  COVERED  BY  THE  SPOIL  BANKS  :-F9*2ylXy 
>- ACRES  Vy 

>7X“4)  AVERAGE  SLOPE  OF  THE  AREA  PERPENDICULAR  TO'/y 
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: "F9*2y IX? 


0167 

0168 

0169 

0170 

0171 

0172 

0173 

0174 

0175 

0176 

0177 

0178 

0179 

0180 
0181 
0182 

0183 

0184 

0185 

0186 

0187 

0188 

0189 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

0197 

0198 

0199 

0200 
0201 
0202 

0203 

0204 


C 

1110 

C 

1030 

C 

1040 

C 

1045 


C 

1050 

C 

1060 

C 

1061 


C 

1065 


1066 

C 

1070 

C 

1075 

END$ 


: “F9*2j IX 


>7X“  THE  SPOIL  BANK  AXIS 
> "DEGREES ‘/y 

>7X"5)  COST  OF  GRADING  SPOILS 
>"CENTS/CLU  YD"//y 

81X"IF  YOU  WISH  TO  CHANGE  ANY  OF  THE  ABOVE  VALUES?  ENTER"/? 
SIX-THE  NUMBER  CORRESPOND! NG  TO  THE  ITEM  YOU  WANI  TO  CHANGE* "/ 
gilX"IF  NO  CHANGES  ARE  DESIRED?  ENTER  A ZERO  ->  _") 


F0RMAT(/?5X'ERR0R“->  ILLEGAL  CHOICE  * RE-SELECT ♦ ->  _") 
FORMAT(/" AVERAGE  DISTANCE  BETOiEEN  SPOIL  BANK  PEAKS  <FEET)  - 
FORMAT(/" INITIAL  AVERAGE  SLOPE  OF  THE  SPOIL  BANKS  (DEGREES) 


FORMAT(/*ERROR — > INITIAL  SLOPE  MUST  BE  GREATER  THAN  ZERO"?/? 
S-AND  LESS  THAN  90  DEGREES  <RE-ENTER  «■  V ) 


FORMAT(/"TOTAL  AREA  COVERED  BY  THE  SPOIL  BANKS  (ACRES)  ->  _") 

FORMAT(/"AVERAGE  SLOPE  OF  THE  AREA  PERPENDICULAR  TO  THE"?/? 
S"SPOIL  BANK  AXIS  (DEGREES)  ->  _") 

FORMAl  (/lX":^^>I^NOTE:^^){^  CROPLAND  WILL  NOT  BE  AVAILABLE  AS  A"/ 

> IX"  RECLAMATION  ALTERNATIVE  BECAUSE  THE"/ 

> IX"  GENERAL  SLOPE  OF  THE  AREA  EXCEEDS"/ 

> IX"  5*7  DEGREES"? 

> //?1X"H1T  THE  RETURN  TO  CONTINUE *****_* ) 

FORMAT  (/"ERROR—/  SLOPE  MUST  BE  GREATER  THAN  ZERO"/ 

S'AND  LESS  THAN  SPOIL  BANK  SLOPE*"/) 

FORMAT  (/"ERROR  — / SLOPE  MUST  BE  GREATER  THAN  OR  EQUAL"/ 

S"TO  THE  GENERAL  SLOPE  AND  LESS  THAN  90*"/) 


FORMAT(/"COST  OF  GRADING  SPOILS  ( CENTS/CU * YD ) -/  _") 


FORMAT(/? 1X"ERR0R-/  VALUE  MUST  BE  6REAIER  THAN  ZERO  -/_") 
END 
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gDLOID  T=00004  IS  ON  CR00015  USING  00028  BLKS  R=0000  . 

0001  FTN4 

0002  SUBROUTINE  DLOID 

0003  C DRAGLINE  : OPENING  CUT  INITIAL  DATA  

0004  C 

0005  C LEOEL  2 

0006  C 

0007  C DLOID  IS  ACCESSED  BY  GDE  TO  SCHEDULE  INPUTS  AND  EDITS  TO 

0008  C THE  INITIAL  DATA  FOR  THE  DRAGLINE  / OPENING  CUT  OPTION 

0009  C 

0010  C ■lOPTN*  IS  A SWITCH  WHERE  : 

0011  C 1 - INPUT  MODE 

0012  C 2 - EDIT  NODE 

0013  C 3 - TEMPORARY  EDIT  MODE 

0014  C 

0015  C THE  CALLING  SEQUENCE  IS  : CALL  DLOID 

0016  C 

0017  C DLOID  USES  THE  TCS  ROUTINES  : ERASE  AND  HOME 

0018  C 

0019  C “IANS'  IS  THE  LOCAL  ANSWER  CELL 

0020  C 'SLMIN"  IS  THE  MINIMUM  SLOPE  VALUE 

0021  C 

0022  C THIS  ROUTINE  WAS  WRITTEN  BY  GREEN?  BUT  PATTERNED  AFTER 

0023  C A ROUTINE  WRITTEN  BY  EASTMAN.  (GRADE) 

0024  C 

0025  C CLAIM  RELEASE  1.0  - APRIL  1?  1980 

0026  C 

0027  C 

0028  C 

0029  C 

0030 

0031  C 

0032  C 

0033  C 

0034 

0035  C 

0036  C 

0037  C 

0038 

0039 

0040 

0041 

0042 

0043 

0044  C 

0045  C 

0046  C 

0047 

0048 

0049 

0050  C 

0051  C 

0052  C 

0053 

0054 


TEKTRONIX  COMMON 


COMMON  ITEK  (45) 


LOGICAL  UNITS  AND  COMMON  LOCATION 
COMMON  IARRY(5) ? 1 ARY2 ( 5 ) ? LER ? LUF ? LUL 
POINTERS 

COMMON  EXIT  ? IANM(3) ? ICLl (2) ? IGEN(3) ? IGRW(5) 

COMMON  lOPTN  ? lOVR ( 7 ) ? IPNTR  ? ISOC ( 6 ) ? ISUB ( 8 ) 

COMMON  ISUR(6) ? IT0P(9) ? IVEG (2 ) ? LEXIT  ?LUO 
COMMON  MODE  ?NANM  ?NCLI  ?N6EN  ?NGRW 

COMMON  NOVR  tNSECTS  ?NS0C  ?NSUB  ?NSUR 

COMMON  NT  OP  ?NU  ?NVE6 

GRADING  PARAMETERS 

COMMON  AREA (5) ? BENLEN ( 5 ? 10 ) ? BENWI ( 5 ? 10 ) ? COGO ? GCPA ( 5 ) 
COMMON  GRDUBS(5) ? HWHT ( 5 ? 10 ) ? HWSLI ( 5 ? 10 ) ?NSPP(5) ?PCEQ19(4 ) 
COMMON  PERCNT(5? 10) ? REHCPY ( 5 ) ? REHVOL ( 5 ) ? SLOPE ( 5 ? 10 ) ?WBP 

CATEGORY  TEXT 


COMMON  ANIM(23? 13) ?CLMA( 13? 13) ?GDES( 15? 13) ?GWHY(22? 13) 
COMMON  OVBD( 11 ? 13) ?SBSL( 13) ? SCEC(33? 13) ?SWHY(44? 13) 
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COMMON  TPSL(49t13) jV6TA(15yl3) 


0055 

0056  C 

0057  C 

0058  C 

0059 

0060 
0061 

0062  C 

0063  C 
•0064  C 

0065 

0066 

0067 

0068  C 

0069  C 

0070  C 

0071 

0072 

0073 

0074 

0075 

0076 

0077  C 

0078 

0079 

0080 
0081 
0082 

0083 

0084 

0085 

0086  C 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094  C 

0095 

0096  C 

0097 

0098 

0099 

0100 
0101 
0102 

0103  C 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


EXPECTATION  VALUES 


COMMON  ANIMAL  < 13  ? 6 ) y CLIMAT  ( 8 y 6 ) ? OENDES  ( 8 y 6 ) y GFavIHYD  ( 19  y 
COMMON  0VRBDN<2Sy6) y SOCECN < 29 y 6 ) y SUBSOI < 30 y 6 ) ySURHYLK2 
COMMON  T0PS0I(33y6) y VEGE TA ( 10 y 6 ) 


CATEGORY  RESPONSES 

COMMON  RANIMA(3) y RCLIMA(2) yRGENDE(3) yRGRUHY(5) 
COMMON  R0'v'RBD<7y  10)  yRS0CEC(6)  yRSUBS0(8)  yRSURHY(6) 
COMMON  RT0PS0(9)  yR'v'EGET(2) 

FEASIyTECONyOPUSE  SUBSYSTEM  PARAMETERS 

COMMON  CAAHM  y CABAM  y CABFN ( 3 ) y CABFP ( 3 ) y CABHM 

COMMON  CABS ( 2 ) y CAC  y CACP  y CADF  y CABH 

COMMON  CADS  y CAEAF  y CAHSAF  y CAHSTS  y CAIP 

COMMON  CAR3FC  y CASE  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y FAVG  < 5 ) y PFSTSP  y PF AC  y RCLTEC ( 29  y 34 ) 

COMMON  TCAR ( 5 ) y THICK ( 10 ) y THKTS  y TTL ( 40 ) 


INTEGER  EXI T y CLMA  y GDES  y OWN Y y OVBD  y SBSL 
INTEGER  SCEC  y SUHY  y TPSL  y VGTA  y ANIM 
INTEGER  CLIMAT  y GEMDES  y GRUHYD  y OVRBDN 
INTEGER  SOCECN  y SUBSOI y SURHYB  y TOPSO I 
INTEGER  VEGETAy ANIMAL 

INTEGER  RCLIMA  y R6ENDE  y RGRUHY  y ROVRBD  y RSOCEC 
INTEGER  RSUBSO  y RSURHY  y RTOPSO  y RVEGET  y RANIMA 
INTEGER  RCLTEC y TTL 

INTEGER  COMMON  (1) 

EQUIVALENCE  (COMMON  (l)y  ITEK  (D) 

EQUIVALENCE  (lARRY  (l)y  LUT) 

EQUIVALENCE  (IARY2  (l)y  ISTRK) 

EQUIVALENCE  (1ARY2  (2)y  ISECT) 

EQUIVALENCE  (IARY2  (3)y  ICODE) 

EQUIVALENCE  (IARY2  (4)y  LEN) 

\ 

LOGICAL  LER 

DISPLAY  TITLE  AND  ASSIGN  MINIMUM  SLOPE 

EXIT=1 

SLMIN=11» 

IF(M0DE*EQ*4)  SLMIN  =••  0.1 

1 IF  <LER)  CALL  ERASE 
IF  (LER)  CALL  HOME 

WRITE  (LUTylOOO) 

FOR  EDIT  MODE  (lOPTN  = 2)y  DISPLAY  THE  CURRENT  DATA 
IF  ( lOPTN.EQ.l  ) GOTO  30 
WRITE  (LUTy  1100)  (GRDVBS  (JJ)y  JJ  = ly  4)y  COGO 

2 READ  (LUTy  t)  IANS 

IF(IANS.EQ.O)  GOTO  4 

IF  (I ANS . 6E . 1 ♦ AND . 1 ANS . LE . 5 ) 

>GOTO  ( 30 y 40 y 50 y 60 y 70  ) IANS 
WRITE  (LUTy 1110) 
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'O  h-) 


0111 

GOTO  2 

0112 

4 

IF(I0PTN*EQ*3)  lOPTN  = 1 

0113 

RETURN 

0114 

C 

USER  INPUT  ->  HEIGHT  OF  THE  SPOIL  BANK 

0115 

30 

WRITE  (LUTj1030) 

0116 

READ  (LUfyj^:)  6RD0BS  <1) 

0117 

IF(I0PTN*NE*1)  GOTO  1 

0118 

IF  (GRDOBS  (1)*6E*0*)  GOTO  40 

0119 

EXIT  = 0 

0120 

RETURN 

0121 

C 

USER  INPUT  ->  AOERAGE  SLOPE  OF  THE  SPOILS 

0122 

40 

WRITE  (LUTj1040) 

0123 

READ  (LUfy^;)  GRDOBS  (2) 

0124 

IF<I0PTN*NE*3)  GOTO  41 

0125 

IF(GRD0BS<2) * GE ♦ AHAXK GRDUBS ( 4 ) ySLHIN) ♦ AND . GRDUBS ( 2 ) *LT*90* ) 

0126 

> GOTO  1 

0127 

WRITE(LUTy 1066) 

0128 

GOTO  40 

0129 

41 

1 F ( GRDVBS ( 2 ) ♦ LT  * 90 ♦ AND ♦ GRDUBS ( 2 ) . GE ♦ SLMI N ) 

0130 

> GOTO  (50yl?l)  lOPTN 

0131 

43 

WRITE  (LUr?1046)  SLNIN 

0132 

GOTO  40 

0133 

C 

USER  INPUT  ->  LENGTH  OF  THE  SPOIL  BANK 

0134 

50 

WRITE  (LUfylOSO) 

0135 

52 

READ  (LLIfyJfO  GRDUBS  (3) 

0136 

IF(GRD0BS(3) *GT»0* ) GOTO  55 

0137 

WRITE(LUTy 1055) 

0138 

GOTO  52 

0139 

55 

IF(IOPTN*NE.l)  GOTO  1 

0140 

C 

USER  INPUT  ->  GENERAL  SLOPE  OF  THE  AREA 

0141 

60 

WRITE  <LUTyl060) 

0142 

- 

READ  (LUTy)|-0  6RDMBS  (4) 

0143 

IF  (GRDOBS  <4) ♦LT»6RDUBS  ( 2 ) ♦ AND  * 6RDUBS  (4)*GE*0) 

0144 

>G0T0(70yly 1)  lOPTN 

0145 

WRITE(LUTy 1065) 

0146 

GOTO  60 

0147 

C 

USER  INPUT  ->  COST  OF  GRADING  OOERBURDEN 

0143 

70 

WRITE  (LUT?1070) 

0149 

72 

READ  (LUT?:^)  COGO 

0150 

IF(C060  *GT*  0*)  GOTO  73 

0151 

WRITE(LUT? 1055) 

0152 

GOTO  72 

0153 

73 

IF<I0PTN*EQ*2)  GOTO  1 

0154 

I0PTN=3 

0155 

GOTO  1 

0156 

C 

FORh'AT  STATEMENIS 

0157 

1000 

FORMAT  (//• DRAGLINL/0PENIN6  CUT  "//) 

0158 

C 

0159 

1100 

FORMAT  C/?5X“CURRENT  OALUES  FOR  THE  DATA  ARE  J“/y 

0160 

S7X‘l*)  HEIGHT  OF  THE  SPOIL  BANK  :*F13*2?lXy 

0161 

S'FEET'/y 

0162 

S7X*2»)  INITIAL  AMERAGE  SLOPE  OF  THE  SPOIL  :"F13*2ylX? 

0163 

g- DEGREES 

0164 

g7X"3*)  LENGTH  OF  THE  SPOIL  BANK  :-F13*27lXy 

0165 

g* YARDS"/? 

0166 

g7X"4*)  AOERAGE  SLOPE  OF  THE  AREA  :"F13,2ylXy 
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0167 

0168 

0169 

0170 

0171 

0172 

0173 

0174 

0175 

0176 

0177 

0178 

0J79 

0180 

0181 

0182 

0183 

0184 

0185 

0186 

0187 

0188 

0189 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

0197 

0198 


: 'F13»2y IXy 


C 

C 

C 

C 

C 

C 

C 


STiEGRELSVy 

S7X-5.)  COST  OF  OF-.-ADlMG  SF’OILS 
X“CENTS/CU  YD“///, 

&1X'  IF  YOU  WISH  TO  CHANGE  ANY  OF  THE  ABOOE  OALUESy  ENTER*/? 
SIX'THE  NUMBER  CORRESPONDING  TO  THE  ITEM  YOU  WANT  TO  CHANGE* “/? 
SIX*  IF  NO  CHANGES  ARE  DESIRED?  ENTER  A ZERO  ->  _“) 

1110  FORMAT  (/?5X  "ERROR—;:--  ILLEGAL  CHOICE  * RE-SELECT  * >. " ) 

1030  FORMAT  (/'HEIGHT  OF  THE  SPOIL  BANK  (FEET)  ->  _') 

1040  FORMAT  (/"INITIAL  AVERAGE  SLOPE  OF  THE  SPOIL  (DEGREES)  ->  >. " ) 

1046  FORMAT  (/2X" ERROR  SLOPE  MUST  BE  GREATER  THAN  "F5*2y/ 

.>  2X'  DEGREES  AND  LESS  THAN  90  DEGREES"/) 

1050  FORMAT  (/"LENGTH  OF  THE  SPOIL  BANK  (YARDS)  _") 

1055  FORMAT(/y  lX"ERROR-.>  VALUE  MUST  BE  GREATER  THAN  ZERO  -.>_") 

1060  FORMAT  (/“AVERAGE  SLOPE  OF  THE  AREA  PERPENDICULAR  TO"?/? 

;::'THE  SPOIL  BANK  AXIS  _") 


C 


1065  FORMAT  ( / ' :fr4<:^ERR0R)t::<=;:<i 
S"THE  INITIAL  SLOPE"?/ 

1066  FORMAT  (/":^::^){^ERROR:^:|o^^ 

EQUAL  TO  THE  GENERAL 


GENERAL  SLOPE  MUST  BE  LESS  THAN" IX 
?"AND  NOT  LESS  THAN  ZERO  * " ) 

SLOPE  MUST  BE  GREATER  THAN  OR'/ 

SLOPE  (OR  11  DEG)?  AND  LESS  THAN  90 


C 


1070  FORMAT  (/"COST  OF  GRADING  SPOILS  ( CENTS/CU * YD ) „") 


C 


END 


/) 


END$ 


.f- 
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SIfLRLE  T = 00004  IS  ON  Cf-:00015  USING  00009  BLKS  fv'==0110 


0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 

0053 

0054 


FfM4 

SUBROUTINE  DLRLE 

C DRAGLINE  RELATIONSHIP  EXECUTIOE  

C 

C LEOEL  3 
C 

C DLRLE  IS  ACCESSED  BY  DLGE  TO  DRAW  GRAPHS  OF  THE  DRAGLINE 
C FINAL  SLOPE  RELATIONSHIPS?  OR  TO  PRINT  TABLES  OF  SANE* 

C 

C THE  CALLING  SEQUENCE  IS  : CALL  DLRLE 

C 

C SUBROUTINES  SCHEDULED  BY  DLRLE  ARE! 

C 

C BUILD  TO  BUILD  A TABLE  OF  UOLUMES ? COSTS  AND  WIDTHS 

C GRAFS  TO  DRAW  GRAPHS  OF  OOLUNES ? COSTS  AND  WIDTHS 

C DLTDR  TO  DISPLAY  A TABLE  OF  UOLUNES ? COSTS  AND  WIDTHS 

C 

C LOCAL  OARIABLES  ARE: 

C 

C •'IANS"  ~ LOCAL  ANSWER  CELL 

C 'LP"  “ LOGICAL  UNIT  OF  THE  LINE  PRINTER 

C 

C RATHER  THAN  DECLARE  THE  ENTIRE  CLAIM  COMMON  BLOCK?  THE 
C ARRAY  "ICOM"  IS  USED?  AND  THE  COMMON  VARIABLES  "LUT"? 

C 'LUL*?  'RGENDE"?  “LER“y  AND  “IPNTR“  EQUIVALENCED  TO 
C THE  APPROPRIATE  ICON  ENTRY 
C 

C DLRLE  DECLARES  LABEL  COMMON  TABLE 
C 

C DLREE  IS  SWAPPED  IN  BY  PROGRAM  DLRLX 
C THIS  ROUTINE  WAS  WRITTEN  BY  GREEN 
C 

C CLAIM  RELEASE  1*0  - APRIL  1?  1980 

C 

COMMON  IC0M<6176) 

INTEGER  RGENDE<3) 

LOGICAL  LER 

EQUIVALENCE  ( IC0M(81 ) ? IPNTR) 

EQUIVALENCE  < ICON ( 56 ) j LER ) 

EQUIVALENCE  (ICON (58) ?LUL) 

EQUIVALENCE  (I COM (46) ?LUT) 

EQUIVALENCE  ( ICON ( 4944 )? RGENDE ( 1 ) ) 

C 

C 

COMMON  /TABLE/ 

> TBLV?  TBLT?  TBLA?  TBLS?  JCOUNT ? TSMIN ? KOD 

> TSMAX  ? TVMIN  ? T VHAX  ? T AMIN  ? TAM AX ? TTMI N ? TTMA 
C 

DIMENSION  TBLV(12) ?TBLT(12) ?TBLA(12) ?TBLS(12) 

DATA  LP/6/ 

C FIRST?  BUILD  THE  TABLES 

K0DE=:^2 
CALL  BUILD 
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0055 

0056 

0057 

0058 

0059 

0060 

0061 

0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 


ro  ro 


GOTO ( 1 00 » 200 j 300)  IPNTR 
C DRAW  THE  GRAPHS 

100  CALL  GRAES 
RETURN 

C PRINT  THE  TABLES 

00  WRITE(LUT j201 ) 

01  FORMAT ( IX "DISPLAY  ON  TT  OR  LP  ->  _") 
READ (LUTy 202)  IANS 

202  FORMAT (A2) 

LUL=LUI 

IF(IANS»EQ*2HLP)  LUL=LP 

CALL  DLTDR(LUL?LU  f ?LER>RGENDE(2) ) 

C SIMPLE  ENOUGH*  LET"S  QUIT 

300  RETURN 
END 

END$ 
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0006 

0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 


FTN4 

SUBROUTINE  DLRSL 

C DRAGLINE  RECONNENDED  SLOPES  AND  PERCENTS  

C 

C LE'v'EL  3 
C 

C DLRSL  IS  ACCESSED  BY  DLGE  TO  READ  THE  RECOMMENDED  SLOPE/PERCENT 
C PAIRS. 

C 

C THE  CALLING  SEQUENCE  IS  : CALL  DLRSL 

C 

C SUBROUTINES  CALLED  ARE: 

C 

C DLIRM  TO  READ  THE  RECOMMENDED  SLOPE/PERCENT  PAIRS  FOR  THE 

C MINE  RUN  OPTION 

C DLIOF  TO  READ  THE  RECOMMENDED  SLOPE/PERCENT  PAIRS  FOR  THE 

C OPENING  AND  FINAL  CUT  OPTIONS 

C 

C RATHER  THAN  DECLARE  THE  ENTIRE  CLAIM  COMMON  BLOCK j.  THE  ARRAY 
C ICOM  IS  USED?  AND  “EXIT*  AND  "RGENDE*  EQUIOALENCED  TO  THE 
C APPROPRIATE  ICOM  ENTRY. 

C 

C DLRSL  IS  SUAPPED  IN  BY  PROGRAM  DLRSX. 

C (THIS  PROGRAM  WAS  SEGMENTED  IN  ANTICIPATION  OF 
C FURTHER  DEVELOPMENTS  FOR  RECOMMENDED  SLOPES) 

C 

C 

C THIS  ROUTINE  WAS  WRITTEN  BY  GREEN 
C tttttttttt  CLAIM  RELEASE  1.0  - APRIL  1?  1980 
C ‘ 

C 

COMMON  ICOM (6176) 

INTEGER  RGENDE(3) 

EQUIVALENCE  (ICOM (59) ?EXIT) 

EQUIVALENCE  (1C0M(4944) ?RGENDE<1) ) 

C SCHEDULE  THE  APPROPRIATE  SUBROUTINE 

IF ( RGENDE ( 2 ) . EQ . 2 ) CALL  DLIRM 
IF(RGENDE(2)  <-NE.2)  CALL  DLIOF 
C THAT  WAS  EASY.  LET'S  QUIT 

RETURN 
END 

END$ 


133 


?;dLst 

0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 

0011 

0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 

0021 

0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 

0053 

0054 


T = 00004  IS  ON  CROOOIS  USING  00042  BLKS  R=^0217 


nN4 


C 

C 

C 

C 

C 

C 

c 

c 


SUBROUTINE  BEST 
DRAGLINE  SUMMARY  TABLE 


LEOEL  3 


DLST  IS  ACCESSED  BY  DL6E  TO  PRESENT  A SUMMARY  TABLE  OF  OOLUMES 
AND  COSTS  FOR  ALL  OF  THE  DRAGLINE  CUT  OPTIONS. 


THE  CALLING  SEQUENCE  IS  : 


CALL  DLST 


SUBROUTINES  SCHEDULED  BY  DLST  ARE  t 


COST 

CPA 


IANS 


C 
C 

c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 
c 

C 

c 

c 

c 


DLGCO  TO  COMPUTE  THE  GRADING  COSTS  AND  OOLUMES  FOR  THE 
OPENING  CUT  OPTION 

DLGCM  TO  COMPUTE  THE  GRADING  COSTS  AND  OOLUMES  FOR  THE 
MINE  RUN  OPTION 

DLGCF  TO  COMPUTE  THE  GRADING  COSTS  AND  VOLUMES  FOR  THE 
FINAL  CUT  OPTION 

DLST  USES  THE  TCS  ROUTINES  : BELL, ERASE y AND  HOME 

AND  DECLARES  LABEL  COMMON  ALTRN  AND  LABEL  COMMON  TABLE 

THE  LOCAL  VARIABLES  ARE: 

ACRES  “ ACRES  COVERED  BY  GRADING  TO  A SPECIFIC  SLOPE/PERCENT 
PAIR  (IN  ACRES) 

~ COST  OF  GRADING  FOR  A SPECIFIC  SLOPE/PERCENT  PAIR  (IN  $) 
“ COST  PER  ACRE  OF  GRADING  FOR  A SPECIFIC  SLOPE/PERCENT 
- PAIR  (IN  DOLLARS/ACRE) 

--  LOCAL  ANSWER  CELL 

ICHAR  - TINPT  RETURN  CELL 

LP  “ LOGICAL  UNIT  OF  THE  LINE  PRINTER 

TACRES  - TOTAL  ACRES  COVERED  BY  GRADED  SPOILS  (IN  ACRES) 

TCPA  - TOTAL  COST  PER  ACRE  TO  GRADE  SPOILS  (IN  DOLLARS/ACRE) 

TLSB  - HYPOTHETICAL  TOTAL  LENGTH  OF  THE  SPOIL  BANK  FOR 
THE  MINE  RUN  SPOILS  (IN  FEET) 

TOTCST  “ TOTAL  COST  OF  GRADING  (DOLLARS) 

TOTVOL  - TOTAL  VOLUME  GRADED  (CUBIC  YARDS) 

VOL  - VOLUME  GRADED  FOR  A SPECIFIC  SLOPE/PERCENT  PAIR 
(IN  CUBIC  YARDS) 

WIDTH  ~ WIDTH  OF  THE  FINAL  BANK  FOR  THE  OPENING  CUT  (IN  FEET) 


THIS  ROUTINE  WAS  WRITTEN  BY  GREEN  / EASTMAN 
(PATTERNED  AFTER  •GRADE"  BY  EASTMAN) 


CLAIM  RELEASE  1.0 


APRIL  1,  1980 


TEKTRONIX  COMMON 
COMMON  ITEK  (45) 
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0055  C 

0056  C 

0057 

0058  C 

0059  C 

0060  C 

0061 
0062 

0063 

0064 

0065 

0066 

0067  C 

0068  C 

0069  C 

0070 

0071 

0072 

0073  C 

0074  C 

0075  C 

0076 

0077 

0078 

0079  C 

0080  C 

0081  C 

0082 

0083 

0084 

0085  C 

0086  C 

0087  C 

0088 

0089 

0090 

0091  C 

0092  C 

0093  C 

0094 

0095 

0096 

0097 

0098 

0099 

0100  C 

0101 
0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109  C 

0110 


LOGICAL  UNITS  ANU  COMMON  LOCATION 
COMMON  IARF<Y(5)  jIARY2(5)  7LERjLUF,LUL 
POINTERS 

COMMON  EXIT  j I ANM ( 3 ) y ICLI ( 2 ) j IGEN ( 3 ) j IGRW ( 5 ) 

COMMON  lOPTN  » lOUR ( 7 ) y IPNTR  y ISOC ( 6 ) ? ISUB ( 8 ) 

COMMON  ISUR(6)yIT0P(9)yI0EG(2)yLEXIT  jLUO 
COMMON  MODE  yNANM  yNCLI  yNGEN  ?NGRW 

COMMON  NOMR  yNSECTS  yNSOC  yNSUB  yNSUR 

COMMON  NTOP  y NU  yNOEG 

GRADING  PARAMETERS 

COMMON  AREA(5)  y BENLEN < 5 y 10 ) y BENk'I  < 5 y 10  ) y COGO y GCPA < 5 ) 

COMMON  GRD0BS(5) yHWHT(5y 10) yHWSLI (5y 10) yNSPP<5) yPCEQ19(4) 
COMMON  PERCNT<5y 10) y REHCPY(5) y REHOOL ( 5 ) y SLOPE ( 5 y 10 ) y WBP 

CATEGORY  TEXT 

COMMON  ANIM(23y  13)  yCLMA(13y  13)  yGDESdSy  13)  yGUHY(22y  13) 
COMMON  OOBDClly 13) ySBSL(13) y SCEC ( 33 y 13 ) y SWHY ( 44 y 1 3 ) 

COMMON  TPSL(49y 13) yUGTA<15y 13) 

EXPECTATION  OALUES 

COMMON  ANIMAL(13y6) yCLIMAT(8y6) yGENDES(8y6) y GRWHYD ( 19 y 6 ) 
COMMON  00RBDN(28y6)  y SOCECM  ( 29 y 6 ) y SLIBSOI  ( 30 y 6 ) y SURH YD  ( 23  y 6 ) 
COMMON  T0PSDI<33y6) y UEGE TA < 1 0 y 6 ) 


CATEGORY  RESPONSES 


COMMON  RANIMA<3) y RCL1MAC2) y RGENDE(3) yR6RUHY(5) 
COMMON  R0VRBD(7y 10) y RS0CEC<6) yRSUBSO(S) yRSURHY<6) 
COMMON  RT0PS0(9) yRMEGET(2) 

KEASIyTECONyOPUSE  SUBSYSTEM  PARAMETERS 


COMMON  CAAHM  y CABAH  y CABFN ( 3 ) y CABFP ( 3 ) y CAEHM 

COMMON  CABS ( 2 ) y CAC  y CACP  y CADF  y CADH 

COMMON  CABS  y CAEAF  y CAHSAF  y CAHSTS  y CAIP 

COMMON  CAR3FC.yCASFy  CASNCyCSTESyCSTRM 

COMMON  CSTRP  y F AMG ( 5 ) y PFSTSP  y PFAC  y RCLTEC ( 29  y 34 ) 

COMMON  TCAR(5) y THICK(IO) y THKTS y TTL ( 40 ) 


INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 


EXIT  y CLMA  y ODES  y Gl'JHY  y O'v'BD  y SBSL 
SCEC  y SWHY  y T PBL  y OGTA  y ANIM 
CL I MAT  y GENDES  y GRWHYD  y OORBDN 
SDCECNy SUBSOI ySURHYDy  TOPSOI 
UEGETAy ANIMAL 

RCL 1 MA  y RGENDE  y R6RWHY  y ROURED  y RSOCEC 
RSUBSO  y RSURH Y y RTOPSO  y ROEGET  y RANIMA 
RCLTEC y I TL 


INTEGER  COMMON  (1) 
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0111 

EQUI'v'ALENCE 

(COMMON 

( 1 ) 

y ITEK  (1)) 

0112 

EQUIVALENCE 

(lARRY 

(1)  y 

LU  f ) 

0113 

EQUIVALENCE 

(IARY2 

(1)  y 

ISTRK) 

0114 

EQUIVALENCE 

(IARY2 

(2)  y 

I SECT) 

0115 

EQUIVALENCE 

( IARY2 

(3)  y 

I CODE) 

0116 

EQUIVALENCE 

(1ARY2 

(4)  y 

LEN) 

0117 

0118 

0119 

0120 
0121 

C 

C 

c 

LOGICAL  LER 

C 

0122 

0123 

0124 
0123 
0126 

0127 

0128 
0129 


C 


C 


COHHON  /ALTFsN/  ALTN 
INTEGEFi:  ALTN(6?4) 


COMMON  /TABLE/ 


TBLOy  TBLT»  TBLAy  TBLSy  JCOUNT ? TSMI N y KOBE » 
TSMAX  y TOMIN  y TOMAX  y TAMI N y TAMAX  y T TMI N y TTMAX 


DIMENSION  TBL0(12) y TBLT<12) yIBLA(12) yTBLS(12) 


0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 
014B 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 
0161 
0162 

0163 

0164 

0165 

0166 


C 

C Of-TEF-':  SUMMARY  TABLE  SELECTION 

1 IF-(LER)  CALL  ERASE 

IF(LER)  CALL  F-IOME 

IF- (MODE*  EQ.  4)  GOTO  5 
WR1TE(LU  fy 505) 

505  FORMATdX'SELEGT  TF-iE  SUMMARY  TABLE  YOU  WISH  TO  OIEUV 

> 1X"0~>N0NE“/ 

> IX" 1 “/CROPLAND ■/ 

> IX ' 2-/NATI0E  OEGE 1 ATI ON “ / 

> 1X"3“>UILDLIF"E'/ 

> 1 X • 4 -•  > WATER  R E C R E A T 1 0 N " / 

> - 1X-5-/HIGH  USE*/ 

> IX  "NOTE?  OPTIONS  1 AND  5 NOT  AVAILABLE  F"OR  THE*/ 

> IX"  OPENING  AND  PINAL  CUT  OPTIONS*// 

> 1X*ENTER  YOUR  SELECTION  HERE  ->  _*) 

504  READ(LUTy:FO  LUO 

IF(LU0*EQ*0)  RETURN 

I F ( RGENDE  < 2 ) * EQ  * 2 * AND  * LUO ♦ GT  * 0 * AND ♦ LUO ♦ LE  * 5 ) GOTO  5 
1 F < RGENDE  ( 2 ) . NE  * 2 * AND  * LUO  ♦ GE  * 2 ♦ AND  * LUO  <•  LE  < 4 ) GOTO  5 

506  WRlTECLUTy 1010) 

1010  FORMAT (/5X"ERR0R  ->  ILLEGAL  ENTRY*  RE-lNPU  l ->  _. " ) 

GOTO  504 
5 K0DE=^1 

IF(NSPP(LUO) *EQ*0)  GOTO  506 
IF(M0DE*EQ*4)  UJ0=1 

C SET  LOGICAL  UNIT  OF  LIST  DEOICE 

LP=^=6 

T0T00L==0* 

T0TCST=0* 

TACRES=:0* 

IF(M0DE*NE*4)  GOTO  20 
ALTN(  1 y 

ALTN(ly2)=2HRA 

ALTN(ly3)=:-2HDE 

ALTN(ly4)=:=2H:F^: 

20  WRITE(LUTy999) 
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0167 

0168 

0169 

0170 

0171 

0172 

0173 
017^ 

0175 

0176 

0177 

0178 

0179 

0180 
0181 
0182 

0183 

0184 

0185 

0186 
0187 
0183 

0189 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

0197 

0198 

0199 

0200 
0201 
0202 

0203 

0204 

0205 

0206 

0207 

0208 

0209 

0210 
0211 
0212 

0213 

0214 

0215 

0216 

0217 

0218 

0219 

0220 
0221 
0222 


999  FORHATClXTilSPLAY  ON  TT  OR  LP  ? ->  _ * ) 

RFAD  <LUT?1000)  IANS 

1000  FORMAT (A2) 

LUL=LUT 

IF(1ANS.E0*2HLP)  LUL=LP 
IF(LUL*EQ*LLIT*  AND^LER)  CALL  ERASE 
IF(LUL*EQ.LUr»ANi:uLER)  CALL  HOME 
I F ( LUL  ♦ EQ  < LP  ) k>R  ITE(LULjIOOI) 

1001  FORMAT (IHl) 

GOTO  (100? 200? 300)  RGENHE(2) 

C OPENING  CUT 

100  UR1TE(LUL? 1004)  ( ALTN ( LUO ? J ) ? J=1 ? 4 ) 

1004  FORMAT (lOX- OPENING  CUT  - MA2) 

UR1T£(LUL? 1085) 

1085  FORMAT </? IX 

1 ‘ -^cFINAL  t % OF  t UOLUME  )^WIDTH  OF  4^;  “ 1 3X  * “ 3X  * COST  “ 3X  ^ VIX 

2 *:^:SLOPE  t TOTAL*  GRADED  *THE  FINAL*  “ 4X  “ COST  ‘ 5X  ■’*"  4X 
■f  “PER*'3X"*“/1X 

3 ‘ * ( DEGS ) *LENGTH* ( CU-YDS ) *DANK  ( FT ) * - 1 3X ' * * 3X  * ACRE ” 3X " * “ ) 
URITECLUL? 1086) 

1086  FORMAT  < IX " * “ 6X - * “ 6X  * * ' 8X " * “ 9X “ * * 13X ' * “ lOX " * * ) 

URITECLUL? 1087) 

1087  FORMAT  (X?  59“*'*  ) 

URITECLUL? 1086) 

DO  110  I=1?NSPPCLU0) 

CALL  DL6C0  C SLOPE  C LUO  ? I ) ? PERCNT  C LUO  ? 1 ) ? OOL  ? COST  ? CPA  ? GRDODS  ? 

> COGO?UIDTH) 

URI TE  C LUL  ? loss ) SLOPE  C LUO  ? I ) ? PERCNT  C LUO  ? I ) ? OOL  ? UI DTH  ? COST  ? CPA 


loss  F0RMAT(1X*‘*"F6*  1 "*"F6*  1 “*“F8 


r-t  M « 


F 9 ♦ 0 ' * “ F 1 3 ♦ 2 ‘ * ■*  F 1 0 ♦ 2 “ * " ) 


‘ O 


TOT'v'OL  = TOTOOL  + MOL 
TOTCST  = TOTCST  -f  COST 
ACRES  = COST/CPA 
TACRES  = TACRES  4-  ACREI 
110  CONIINUE 

TCPA  =:  TOTCST/TACRES 
URITECLUL? 1086) 

URITECLUL? 1087) 

URITECLUL? 1086) 

URITECLUL? 1090)  TOTOOL?  TOTCST  ?TCPA 

1090  FORMAT  C IX  ” totals:  2X  ? “ 1 00 . 0 ^ ? IX  ? F8 . 1 ? lOX  ? * $ '^  FI  1 ♦ 2 ? 4X  ? " $ “ ?F7<  2//) 
URITECLUL? 1091 ) TACRES 

1091  F0RMATC//?5X*THE  TOTAL  AREA  COHERED  BY  THE  GRADED  V 

> 5X' SPOILS  IS  ~>  ‘F13<.  1'  ACRES*  “) 

GOTO  500 

C MINE  RUN 

200  URI TE  C LUL  ? 2004 ) C ALTN ( LUO  ? J ) ? J=1 ? 4 ) 

2004  F0RMAT(10X“MINE  RUN  OPTION  - ‘4A2) 

URITECLUL?2005) 

2005  FORMAT (//-  * FINAL  * PERCENT  * VOLUME 

+ "*  AVERAGE  *“/ 

1 ? * * SLOPE  * OF  TOTAL  * MOVED  * 

4-  “ COST  *’  / 

2 ‘ * (DEGREES)  * AREA  * (CU-YDS)  * 

4-  “ PER  ACRE  *‘) 

URITECLUL? 2010) 

2010  FURMATC“  * “ SC**)"  * “ IOC'**) 


* 

GRADING 

COST 


*”  ? 
* *■ 


1 1 C ‘ * - ) “ * 


1 1 c • * “ ) 


■ \ • ,L-  « 
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0223 

0224 

0225 

0226 

0227 

0228 

0229 

0230 

0231 

0232 

0233 

0234 

0235 

0236 

0237 

0238 

0239 

0240 

0241 

0242 

0243 
024  4 

0245 

0246 

0247 

0248 

0249 

0250 

0251 

0252 

0253 

0254 

0255 

0256 

0257 

0258 

0259 

0260 
0261 
0262 

0263 

0264 

0265 

0266 

0267 

0268 


-I-  ■ ) 

WKITE(LLILy2020) 

2020  F ORMAT  ( “ *■  , 1 IX  y " ^ 12X  y * " y 1 3X  y “ " y 1 3X  y “ ? 12X  ? * * ) 

DO  220  I = lyNSF‘P(LUO) 

CALL  DLGCM  ( SLOF'E  ( LUO  y I ) y PFIRCMT  ( LUO  y I ) y OOL  y COST  y TLSB  y GRDUB8  y COGO  > 
TOTOOL  = TOTOOL  + VOL 
TOTCST  = TOTCGT  T COST 

ACRES  = ( (TLSB)KPERCNT(LUOy  D/lOO*  )X((GRDVBS(l)/3*  ) ) /4840c 
CPA  = COST/ACRES 

WRITE(LULy2030)  SLOPE<LUOy I) y PERCNT ( LUO y I ) y VOL y COST y CPA 


Pllc2y 


2030  FORMAT  (•  t * y F4  ♦ 1 y 4X  y “ ‘ y 4X  y F4  C 1 y 3X  “ * "yPlOcly" 

+ “ yF9c2y  “ )fc'  ) 

220  COiNTINUE 

TCPA  = TOTCST  / 6RDVBSC3) 

WRlTE(LULy2020) 

WRITE(LULy2010) 

WRITE(LULy2090)  TOTVOLy  TOTCST  yTCPA 
2090  FORMAT </5Xy -TOTALS: “ y 5X y * 100  * 0 “ y 6X y FIO c 1 y 3X y * $ “ y FI 1 ♦ 2 y 3X y 
1 yF9c2y5/> 

GOTO  500 

C FINAL  CUT 

300  URITE(LULy3004)  (ALTN(LUDy J) y J=ly4) 

3004  F0RMAT(10X"FIMAL  CUT  - '4A2) 

WRITE(LULy 3005) 

3005  FORMAT (//“  t FINAL  t PERCENT  t VOLUME 

+ AVERAGE  f/ 

1 y • SLOPE  t OF  TOTAL  t MOVED  t 

1 " COST  f / 

2 - t (DEGREES)  t LENGTH  t (CU-YDS)  t 
T • PER  ACRE 

yRITE(LLlLy  3010) 

3010  FORMAT(-  >1^  - 9( -:((•)•  t * 10(")|c')“  :^c  - 1 1 ( • • ) ' « ' llOf:')' 

•f  ■ f) 

WRITE(LULy 3020) 

3020  FORMAT  ( “ f flix,  - JK-  y 12Xy  y 13Xy  y 13Xy  -)K-  y 12Xy  ->K-  ) 

DO  310  I=--^lyNSPP(LUO) 

CALL  DLGCF  < SLOPE ( LUO  y I ) y PERCNT ( LUO  y I ) y WBP  y GRDVBS  y COGO  y 
> VOL y COST  7 ACRES) 

TOTVOL  =-•  TOTVOL  -F  VOL 
TOTCST  = TOTCST  T COST 
CPA  = COST/ACRES 
TACRES  ==  TACRES  -}•  ACRES 

WR I TE ( LUL  y 3030 ) SLOPE ( LUG  ? I ) y PERCNT ( LUO  y I ) y VOL  y COST  y CPA 
3030  FORMA  T <“  - y F4  * 1 y 4X y “ :4c  “ y 3X  y F5  » 1 y 3X  • t *yF10*ly“  y Fllc2y 

T “ t $•  yF9c2y  * ) 

310  CONTINUE 


GRADING 

COST 


t 


0269 

TCPA  = TOTCST  / 

TACRES 

0270 

WRITE(LULy3020) 

0271 

WRITE (LUL 73010) 

0272 

WRITE(LUL73090) 

TOTVOLy 

0273 

3090  F0RMAT(/5Xy “TOTALS: “ ybX: 

0274 

1 “$“yF9*2y5/) 

0275 

WRITE (LUL 7 1091 ) 

TACRES 

0276 

500  ALTN(l7l)=::2HCR 

0277 

ALTN(ly2)=^:2H0P 

0278 

ALTN(ly3)-2HLA 
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0279 

0280 
0281 
0282 
0283 
028^. 

0285 

0286 
0287 


ALTNd  j4)=2HMD 
WRITE (LUfy 501 ) 

501  FORMAK/V?  1X“HIT  THE  RETURN  KEY  TO  CONTINUE*f 
CALL  BELL 
CALL  TINPT(ICHAR) 

IF(H0DE*EQ.4)  RETURN 

GOTO  1 

END 

END$ 
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SDLTDR  1=00004  IS  ON  CR00015  USING  00011  BLKS  R=0051 


0001 

0002 

0003 

0004 
OOOU 
0006 

0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 
OOIG 
0016 
0017 

0015 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 
0 O 4 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 

0053 

0054 


FTN4 

SUBROUTINE  BLTDR ( LUL y LUT y LER y ICU T ) 

C DRAGLINE  : TABLES  OF-  THE  DRAGLINE  RELATIONSHIF’S 

C 


C 

C 

C 

C 

C 

c 

c 

c 

c 

c 

G 

C 

C 


C 


C 

C 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


c 


c 


c 

c 


LEVEL  4 

DLTDR  IS  ACCESSED  BY  DLRE  TO  PRINT  THE  TABLE  OF  THE 
DRAGLINE  RELATIONSHIPS* 

THE  CALLING  SEQUENCE  IS  : 

CALL  DLTDR  ( LUL y LUT y LER y ICUT ) 

UHERE 

LUL  IS  THE  LOGICAL  UNIT  OF  THE  LIST  DEVICE 
LUT  IS  THE  LOGICAL  UNIT  OF  THE  USER''S  TERNIMAL 
LER  IS  *TRUE*  FOR  ERASE  CAPABILITY 
ICUT  IS  THE  CUT  OPTION 

DLTDR  USES  THE  TCS  ROUTINES  : BELL y ERASE  HOME  AND  TINPT 
AND  DECLARES  LABEL  COMMON  TABLE* 


THE  CLAIM  COMMON  BLOCK  IS  NOT  DECLARED* 

“ICHAR"  IS  THE  TINPT  RETURN  CELL 

•'LP"  IS  THE  LOGICAL  UNIT  OF  THE  LINE  PRINTER 

THIS  ROUTINE  WAS  WRITTEN  BY  GREEN/EASTMAN 

CLAIM  RELEASE  1*0  - APRIL  ly  1980 


COMMON  ITEK<45) 

COMMON  /TABLE/ 

TBLVy  TBLTy  TBLAy  TBLSy  JCOUNT y TSMI N ? KOBE ? 
TSMAXy  T VMINy  TVMAXy  TAMIN?  TAMAX y TTMI N y TTMAX 


LOGICAL  LER 

DIMENSION  TBLV(12) yTBLT(12) yTBLA(12) yTBLS(12) 


DATA  LP/6/ 

1F(LUL*EQ*LUT* AND*LER)  CALL  ERASE 
IF ( LUL *EQ* LUT* AND* LER)  CALL  HOME 
IF ( LUL  * EQ  * LP ) WRITE ( LUL  y 999 ) 
IF<ICUT*EQ* 1 ) WRITE(LULy 1000) 
IFdCUT  *EQ*2)  WRITE(LULy  1001  ) 

I F ( I CUT  * EQ  * 3 ) WR I TE ( LUL  y 1 002 ) 

1F( ICUT*NE* 1 ) WRI TE< LUL y 1003) 
IFCICUT*EQ* 1 ) WRITE<LULy 1008)  ' - 

WRI TEC LUL y 1004) 

WRITECLULy 1005) 
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0055 

0056 

0057 

0058 

0059 

0060 
0061 
0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 
OOBl 


10 


no  10  K=^lyJCOUMT 

WRITECLUL? 1006)  TBLS ( K ) ? TBLO ( K ) » TBLT ( K ) j TBLA ( K ) 
WRITECLUL? 1004) 


999 

1000 

1001 

1002 

1003 


WRITE<LUL?1005) 

IF(LUL.NE*LUr*OR*  *MOT*LER)  RETURN 
URITECLULy 1007) 

CALL  BELL 

CALL  TINPTdCHAR) 

CALL  ERASE 
CALL  HOHE 
RETURN 
FORMAT (IHl) 

F0RHAT(10X*0F-ENING  CUT  OPTION") 


F0RMAT(10X"MINE  RUN  OPTION") 


FORMAT <10X" FINAL  CUT 
FORMAT (//"  t FINAL 
/,“  t SLOPE  t 

U 


OPTION" ) 

t OOLUME 

t SLOPE  t MOOED  t 

t (DEGREES)  t (CU-YDS)  t 
1008  FORMAT(//"  FINAL  t OOLUME 

1 /?")(=:  SLOPE  t MOOED  t 

" t (DEGREES)  t (CU-YDS)  t 


1004 
'5 


10(  - ) 


1005 


1006 


1007 

END$ 


FORMATC  >^:  " 9(“>f:")"  t 
FORMAT-:  " j IIX?  ? 12Xy  ? 13X?  y 12 
FORMAT  ( " t " ?F4*1  y 4X?  ? IXyFlOd  y “ 

FORMAT (/1X"HIT  RETURN  TO  CONTINUE***** 
END 


t TOTAL 
GRADING  t 

COST  t 

t TOTAL 
GRADING  t 

COST  t 

:Hf.  • 1 1 ("){•:")  * 

":T<"  ) 


t 

COST 

acf:e 

t 


AOERAGE 

PER 

•4'"  ) 
WIDTH 


t 


OF 

FINAL 


THE 

BANK 


f/, 

) 


t 


10("J{i")"  f) 


A y 


$" yF10*2y 


$"yF9*2y"  :4i") 


) 
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&DSPLA  1=00004  IS  ON  CR00015  USING  00020  BLKS  K-0153 


0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 
0017 
OOlS 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 

0053 

0054 


FTN4 

C 


SUBROUTINE  DSPLA 


C LEOEL  5 
C 

C DSPLA  IS  ACCESSED  BY  GRAFS  TO  DISPLAY  THE 
C 

C THE  CALLING  SEQUENCE  IS  : CALL  DSPLA 

C 


CURRENT 


INITIAL  DATA 


C DSPLA  USES  THE  TCS  ROUTINES  : HOME? BELL?  AND  TINPT 
C 

C -ICHAR-  IS  THE  TINPT  RETURN  CELL 


C 

C THIS  ROUTINE  HAS  WRITTEN  BY  EASTMAN/GREEN 
C 

C CLAIM  RELEASE  1*0  ~ APRIL  1?  1980 

C TEKTRONIX  COMMON 

C 

COMMON  ITEK  (45) 

C 

C LOGICAL  UNITS  AND  COMMON  LOCATION 

C 

COMMON  1ARRY(5) y 1ARY2(5) yLERyLUFyLUL 
C 

C POINTERS 

C 

COMMON  EXIT  y IANM(3)  y ICLK2)  y IGEN(3)  ylGRW(5) 
COMMON  lOPTN  y lOOR ( 7 ) y IPNTR  y ISOC ( 6 ) ? I SUB ( 8 ) 
COMMON  ISUR(6) y IT0P(9) y I0EG<2) yLEXIT  yLUO 
COMMON  MODE  yNANM  yNCLI  yNGEN  yNGRW 

COMMON  NO'v'R  yNSECTS  yNSGC  yNSUB  yNSUR 

COMMON  NTOP  y NU  yNUEG 

C 

C GRADING  PARAMETERS 

C 


C 

C 

C 


€ 

C 

C 


C 

C 

C 


COMMON  AREA(5)  y BENLEN  ( 5 y 1 0 ) yBENWKSy  10)  y COGO  y 6CPA  < 5 ) 
COMMON  GRD0BS(5) yHWHT(5y 10) yHWSLKSy 10) yNSPP(5) yPCEQ19<4) 
COMMON  PERCNf (5y 10) y REHCP Y ( 5 ) y REHUOL ( 5 ) y SLOPE (5y 10) y WBP 

CATEGORY  TEXT 

COMMON  AN I M ( 23  y 1 3 ) y CLM A ( 1 3 y 1 3 ) y GDES ( 1 5 y 1 3 ) y GWH Y ( 22  y 1 3 ) 
COMMON  00BD(llyl3)ySBSL(13)y  SCEC ( 33 y 1 3 ) y SWH Y < 44 y 1 3 ) 
COMMON  TPSL(49y 13) yOGTA(15y 13) 

EXPECTATION  MALUES 

COMMON  ANIMAL  ( 13y  6)  yCLIMAKSy  6)  y GENDES  ( 8 y 6 )?  GRWH  YD  ( 1 9 y 
COMMON  00RBDN(2Sy6) y SOCECN ( 29 y 6 ) y SUBSOI ( 30 y 6 ) ySURHYD(2 
COMMON  T0PS0I<33y6) y OEGE TA ( 1 0 y 6 ) 

CATEGORY  RESPONSES 
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W CN 


0055 

0056 

0057 

0058 

0059 

0060 
0061 
0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 
0081 
0082 

0083 

0084 

0085 

0086 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 
0101 
0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


C 

C 

C 


c 


COMMON  RANIMA<3) ? RCLIMA ( 2 ) y RGENDE ( 3 ) ?RGR0HY<5) 
COMMON  ROVRBD (7^10)?  RSOCEC ( 6 ) » RSUEBO ( 8 ) ? RSURHY ( 6 ) 
COMMON  RT0PS0(9) y R0EGET(2) 

FEASI ?T£CONy OPUSE  SUBSYSTEM  PARAMETERS 


COMMON 

COMMON 

COMMON 

COMMON 

COMMON 

COMMON 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 


CAAHM  ? CABAH  y CABFN ( 3 ) y CABFP ( 3 ) y CABHM 

CABS ( 2 ) y CAC  y CACP  y CADF  y CABH 

CADS  y C AEAF  ? CAHSAF  y CAHSTS  y CAI P 

CAR3FC  y CASE  y CASNC  y CSTES  y CSTRM 

CSTRP  y FAUG  < 5 ) y PFSTSP  y PFAC  y RCLTEC ( 29  y 34 ) 

TCAR ( 5 ) y TH I CK ( 1 0 ) y THKTS  y TTL ( 40 ) 


EXI T y CLMA  y GDES  y GWH Y y OUBD  y SBSL 


SCEC  y SWH Y y TPSL  y UGTA  y AN IM 
CL I MAT  y GENDES  y 6RWH YD  y OURBDN 


SOCECN  y SUBSOI y SURHYD  y TOPSOI 
VEGETA y ANIMAL 

RCL IMA  y RGENDE  y R6RUH Y y ROVRBD  y RSOCEC 
RSUBSO  y RSURH Y y RTOPSO  y RVEGET  y RANIMA 
RCLTECy T TL 


C 

C 


INTEGER  COMMON  (1) 

EQUIVALENCE  (COMMON  (l)y  ITEK  (1)) 
EQUIVALENCE  (lARRY  (l)y  LUT) 
EQUIVALENCE  (IARY2  (l)y  ISTRK) 
EQUIVALENCE  (IARY2  C2)y  ISECT) 
EQUIVALENCE  (1ARY2  (3)y  ICODE) 
EQUIVALENCE  (IARY2  (4)y  LEN) 

LOGICAL  LER 


CALL  HOME 
LUD  = 1ARRY(3) 

C BRANCH  TO  CUT  OPTION 

GOTO ( 1 00  y 200  y 300 ) RGENDE  < 2 ) 

C OPENING  CUT 

100  WRITE(LUIiy  1010)  (GRDVBS(K)  yK=ly4)  yCOGO 
1010  FORMAT(/“DRAGLINE  - OPENING  CUT*/ 
T/'CLIRRENT  INPUT  DATA?.*// 

1 'SPOIL  BANK  HEIGHT  J“F7. 2"  FT*'/ 

2" INITIAL  SPOIL  SLOPED* 

3 "SPOIL  BANK  LENGTH 
4 "SLOPE 


4 9 

4 


4 « 

4 


5 "COST 


4 If 
♦ 


OF  THE  AREA 
OF  GRADING 
GOTO  500 

: MINE  RUN 

200  URITE(LUDy2010)  (GRDV 
2010  FORMAT (5X“>fa'  DRAGLINE 
2 2X" CURRENT  INPUT  DATA: 


3 

4 

c 

6 

5 


r"  » 

r / ^ ju. 

DEG  V 

F7»2" 

FT.  •/ 

F7*2* 

DEG"/ 

F5.2" 

C/C“Y“ ) 

1S(K)  y K 

=1 y4) yCOGO 

“ MINE 

RUN  m 

"// 

, : " // 

PEAKS 

: “F7.2" 

Ff/ 

;LOPE 

: "F7.2" 

DG " / 

LS 

4 W r-  • V •'^9 
♦ \ / ^ s.. 

AC " / y 

: AREA 

+ i#  * 

4 r / ♦ ^ 

IiG  • / y 

"DIST*  BETHEEN  SPOIL 
•INITIAL  SPOIL  BANK  S 
"AREA  COVERED  BY  SPOI 
•GENERAL  SLOPE  OF  THE 

•COST  OF  GRADING  OVERBURDEN t “ F5 ♦ 2 ' C/CY") 
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GOTO  500 


0111 

0112 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120 
0121 
0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 


C F'INAL  cur 

300  URITfc;(LUIi»3010)  WBP  y Gf^DOBS » CDGO 
3010  F0P:MAT(5X“){':F^:«  URAGLINl  - f-INAL  CUT 
1 /5X*  CURRENT  INPUT  DATA  f/ 

31X“PIT  BOTTOM  WIDTH  t " P7.2“  FTV 
,41X*PIT  LENGTH  :'F7*2“  YD'/ 

51X'HIGHWALL  HEIGHT  :"F7.2'  FT'/ 

BIX'SPOIL  BANK  HEIGHT  J'F7<2‘  FT'/ 

BIX'HIGHWALL  SLOPE  :'F7*2"  DEGV 
CIX'SPOIL  BANK  SLOPE  :“F7*2*  DEG'/ 

DIX'GRADING  COST  :'F5.2"  C/CY“) 

C DONE*  LET  USER  INSPECT  THE  SCREEN 

500  IF(LUD  .EO*  LUD  WRITE ( LUT y 501 ) 

501  FORMATdX'HIT  RETURN  TO  CONTINUE  ) 

IF(LUD  ♦EQ*  LUl)  CALL  BELL 

IF (LUD  .EQ*  LUT)  CALL  TINPT(ICHAR) 

IF (LUD  *EQ*  LU7)  CALL  ERASE 

IF (LUD  ^EQ*  LUT)  CALL  HOME 

RETURN 
END 

END$ 
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1=00004  IS  ON  CR00015  USING  00030  BLKS  R=0000 


0001 

0002 

0003 

0004 

0005 

0006 
0007 

0003 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 
0017 
001 S 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0 0 o 6 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

004  7 
0043 

0049 

0050 

0051 

0052 

0053 

0054 


FTN4 
C === 
C = 

C = 

C = 

C = 


SUBROUTINE 


DON 


DRAW  OECTOR  NUMBERS 


SOURCE  FILE 


: SDON 


OBJECT  FILE  * 


<•  /u  JLI 


c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


description: 

THIS  ROUTINE  DRAWS  "OECTOR*  NUMBERS  ORIENTATED  IN  ANY  OF 
THE  FOUR  CARDINAL  DIRECTIONS?  DRAWN  CLOCKWISE* 

CALLING  sequence: 

CALL  DON  Cv'ALUE?  ISC?  10C?NDP) 

arguments: 


OALUE 

ISC 

IOC 


->  NUMBER  TO  BE  DRAWN 

ACTUAL  SIZE  OF  CHARACTER  WILL  BE  ISC  t 
ORIENTATION  CODE: 


RASTER  UNITS 


o 

3 

4 


BASE  LIME  ON  BOTTOM 
BASE  LINE  OF  LEFT 
BASE  LINE  ON  RIGHT 
BASE  LINE  ON  TOP 


NDP 


NUMBER  OF  DECIMAL  PLACES  (ACCURATE  TO  3) 


ACCESSED  by: 

TSIFG?  TSXBA?  TSXFS 

SUBROUT INES  SCHEDULED: 

DRWRL  (TCS) 

MOORL  (TCS) 

LOCAL  UARIABLES: 

ICFX  ->  COMMAND  TABLE  FOR  X COORDINATE 
ICFY  ->  COMMAND  TABLE  FOR  Y COORDINATES 
IDXCH  ~>  INDEX  TO  CHARACTER 

INCR  “>  INCREMENT  ADDED  TO  TEST  CHARACTER  LENGTH 
IPTR  “>  LOCAL  POINTER 

IX  ->  ICFX  ENTRIES  DEFINED  BY  IOC 

lY  ">  ICFY  ENTRIES  DEFINED  BY  IOC 

NON  ~>  NUMBER  OF  UECTOR  NUMBERS  TO  BE  DRAWN  O^ONE^S) 

NMNl  ~>  NUMBER  OF  OECTOR  NUMBERS  TO  BE  DRAWN  (<=  “ONES’') 

OAL  ->  SET  TO  OALUE  FOR  LOCAL  MANIPULATIONS 

author:  oroille  d*  green 

LAST  REUISION:  august  15?  1979 
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0055  C 

0056  C 


0057  C =:==:^:^:^  = =:=:  = = = = ===:  = =:===:  = =======r=:============  = =========:=:=: 

0053  C 

0059  SUBROUTINE  DON  ( OALUE ? 1 SC ? I OC ? NDP ) 

0060  COMMON  ITEK  (45) 

0061  INTEGER  IDXCH  (7)y  IPTR  (10), 


0062 

ICFX  (10,8) 

, ICFY 

(10,3 

) , 

IX 

(10 

,8) 

, lY 

0063 

C 

0064 

DATA 

ICFX 

/ 0, 

3 , 

0? 

0, 

2 , 

0, 

0, 

0, 

1 , 

0, 

0065 

- 

3, 

“3, 

1 , 

1 , 

0 , 

0, 

0 , 

3 , 

0, 

3, 

0066 

- 

0, 

0, 

0, 

0, 

_2, 

1 , 

3 , 

“3 , 

-1, 

0, 

0067 

~ 

“3 , 

0, 

2 , 

0, 

3 , 

0, 

0, 

0, 

0, 

0 y 

0068 

- 

0, 

0, 

0 , 

2 , 

“3 , 

2, 

— 2 , 

0 , 

3 , 

-1, 

0069 

- 

0, 

0 , ■ 

"3 , 

0, 

0, 

0, 

0, 

0 , 

0 , 

Oy 

0070 

- 

0, 

0, 

0 , ~ 

3, 

0, 

“3 , 

-1, 

0? 

-2, 

“2  y 

0071 

- 

0 , 

0, 

0, 

0, 

0 , 

0, 

0, 

0, 

~1  y 

0/ 

0072 

C 

0073 

DATA 

ICFY 

/ 3 , 

0 , 

3 , 

3 , 

0, 

3 , 

3, 

3 , 

0, 

3 , 

0074 

” 

0, 

1 , 

0 , 

0, 

3 ? 

-3 , 

“3, 

0 , 

3 , 

0, 

0075 

- 

~*3 , 

0,- 

-3 , “ 

3, 

0, 

0, 

0 , 

1 , 

0, 

~ 3 , 

0076 

- 

0 , 

0, 

0 , 

3 , 

0 , 

3 , 

3, 

0, 

— 3 , 

3, 

0077 

- 

4 , 

0, 

3, 

0, 

1 , 

0 , 

0 , 

0, 

0 , 

Oy 

0078 

- 

0? 

0, 

1 , 

3 , 

0 , 

-3, 

“3 , 

0, 

3 , 

— 3 , 

0079 

- 

() , 

0, 

0 , 

4 , 

0 , 

4 , 

4 , 

0, 

0, 

0 , 

0080 

~ 

0, 

0, 

0 , 

0, 

0, 

0, 

0, 

0, 

1 y 

4/ 

0081 

C 

0082 

DATA 

IPTR 

/ 5, 

2, 

6 , 

7 , 

5 , 

7 , 

7 , 

3 , 

8, 

8 / 

0033 

C 

0034 

C 

I n i' t i s 1 i z 

e 1 oc 

:sl  variable 

arid 

t e 

St 

f o r 

" ones  * 

0085  NON  0 


0086 

0087 

0038 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 
0101 
0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


I NCR  = 0 
NONl  ==  0 
OAL  = OALUE 

IF  ( UAL  .LT*  10)  10,  30 
C Test  MAE  for  dec i ms Is  only  ? 

10  IF  ( UAL  <.LT.  1.  ) 15,  25 
C Dec i ms Is  only  - set  IDXCH  sr rsy  for  NDP  > 0 t 
15  IF  ( NDP  .LE.  0 ) RETURN 
I NCR  2 

IDXCH  (1)  = 0 
IDXCH  (2)  = -1 
OAL  =-•  OALUE  t 10*  + 0*0005 

NONl  = 2 

C DECIMAL  NUMBERS 

20  N'v'Nl  =--^  NONl  T 1 

IDXCH  ( NONl  ) ==  IFIX  ( UAL  ) 

UAL  =:  ( OAL  - FLOAT  ( IDXCH  ( NUNl  ) j ) t 
IF  < NVNl  *EQ.  NON  -}•  NDP  T INCR  ) 900,  20 
C Set  "ones''  place  in  IDXCH  srrsy  Test  NON  si 2 
C Set  decimal  point  for  NDP  > 0 * 

25  IF  ( NON  *EQ*  0)  NON  ==  NON  T 1 
OAL  OAL  + *0005 
IDXCH  < NON  ) IFIX  ( OAL  ) 

IF  ( NDP  *LE*  0 ) GO  10  900 
MOM  ===  NON  T 1 


(10,8) 


p-lsce  J 


10* 

' 0 ifc 
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0111 

0112 

0113 

0114 

0115 

0116 
0117 
Oils 

0119 

0120 
0121 
0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 
0161 
0162 

0163 

0164 

0165 

0166 


IF  ( NON  <BT<.  7 ) GOTO  9010 
IDXCH  ( NON  ) = -1 

C Test  size  ~ Set  NOMl  end  OAL  for  (NON  -f  NDF’) 
IF  ( NON  T NDP  .GT.  7 ) GOTO  9010 
NONl  ==  NON 

OAL  =-•:  ( OAL  ~ FLOAT  ( IDXCH  ( NON  - 1 ) 
GOTO  20 

C WHOLE  NUMDEF(8 

30  NON  =:  NON  T 1 

IF  ( NON  <GTi  7 ) GOTO  9010 

C Test  OAL  for  “ones*  plsce 

IF  ( OAL  *LT.  10  ) GOTO  25 
DO  40  XL  ==  1?  12 
OAL  = OAL  / 10* 

IF  ( OAL  *LT*  10*  ) 45y  40 
CONTINUE 
GOTO  9010 

IDXCH  srray  srid  fix  OAL 
IDXCH  < NON  ) = IF IX  ( OAL  ) 

OAL  = OAL  - FLOAT  ( IDXCH  ( NON  ) ) 

DO  60  ILl  ==  1?  IL 
OAL  = OAL  t 10* 

IF  ( OAL  <LT*  1*  ) 50?  60 
IF  ( ILl  *EQ*  IL  ) GOTO  60 
NON  =:=  NON  T 1 

IF  ( NON  *GT<  7 ) GOTO  9010 
IDXCH  ( NON  ) = 0 
CONTINUE 
GOTO  30 

C'SET  NON 

900  IF  ( NONl  .GTt  0 ) NON  = NONl 

C TEST  ORIENTATION  CODE  t 

GOTO  <920?  940?  960?  980  ) IOC 

C BASE  LINE  ON  BOTTOM  t 
920  DO  930  1 = 1?  10 
DO  930  J =:  1?  8 
IX  < I?  J ) ICFY  ( I?  J ) 

930  lY  ( I?  J ) =-•  -ICFX  < I?  J ) 

GOTO  1000 

C BASE  LINE  ON  LEFT 
940  DO  950  I = 1?  10 
DO  950  J = 1?  8 
XX  ( I?  J ) =::  “ICFX  ( 1?  J ) 

950  lY  < I?  J ) = “ICFY  ( I?  J ) 

GOTO  1000 

C BASE  LINE  ON  RIGHT 
960  DU  970  I 1?  10 
DO  970  J =:  1?  8 
IX  ( I?  J ) =:  ICFX  ( I?  J ) 

970  lY  ( I?  J ) = ICFY  ( 1?  J ) 

GOTO  1000 

C BASE  LINE  ON  TOP  ( WHO  NEEDS  IT  ? ) 

980  DO  990  I ==:  1?  10 
DO  990  J = 1?  8 


40 

C Set 
45 


50 


60 

C 


15 


4 

4 


) t 10* 
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0167 

0168 

0169 

0170 

0171 

0172 

0173 

0174 

0175 

0176 

0177 

0178 

0179 

0180 
OlBl 
0182 

0183 

0184 

0185 

0186 

0187 

0188 

0189 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

0197 

0198 
^ 0199 

0200 

0201 

0202 

0203 

0204 

0205 

0206 

0207 

0208 
0209 


IX  ( Is-  J ) -ICFY  < Ij  J ) 
990  lY  ( l7  J ) = + ICFX  ( ly  J ) 
GOTO  1000 


C DRAW  OECTOR  NUMBER 


1000  IF 

<’ 

\ 

IOC  ♦EQ«  1 

) CALL 

MOURL  ( 

: ISCy 

ISC  ) 

IT 

( 

1 0 L « E Q « 2 

/ 

) CALL 

MO URL  < 

I SC  y 

- 

ISC 

) 

IF 

( 

IOC  *EQ*  3 

) CALL 

MO'ORL  < 

: - ISC 

■ y 

ISC 

) 

IF 

( 

IOC  ♦EG*  4 

) CALL 

MOORL  < 

: -ISCy 

- 

ISC 

) 

DO 

O 

aL 

000  1 ly  NON 

IF 

( 

IDXCH  (I)  ♦ 

EG*  -1 

) GOTO 

1800 

DO 

1 

500  J = ly  IPTR  ( 

IDXCH  (I)  + 1) 

— 

1 

1500  CALL 

DRWRL  ( IX < 

IDXCH 

(1)  + 1 

. y J ) 

ISC 

y 

T 

1Y( 

IDXCH 

(I)  + 3 

y J ) 

ISC 

) 

C POSITION  FOR  NEXT  DRAW 

CALL  MO'v'RL  ( IX  ( IDXCH ( I ) + 1 y IPTR  ( IDXCH ( I ) -M  ) ) t ISCy 
•I  1 Y ( I DXCH ( I ) -}•  1 y I PTR ( I DXCH ( I ) -f  1 ) ) )fc  ISC) 

GOTO  2000 


C DRAW  DECIMAL  POINT 


IF  ( 

IOC  *EG* 

1 

) 

C A L L 

MOURL 

(1 

SC-y  “3  t ISC  ) 

IF  < 

IOC  *EG* 

o 

) 

CALL 

MOURL 

( " 

3 t ISCy  “ISC  ) 

IF  ( 

IOC  *EG* 

~x 

N 

/■ 

CALL 

MOURL 

( 3 

t ISCy  ISC  ) 

IF  < 

IOC  *EG* 

4 

) 

CALL 

MOURL 

(~ 

ISCy  3 ISC  ) 

CALL 

DRWRL  <0 

y 2 ) 

CALL 

MOURL  (- 

1 y “ 

1 

) 

CALL 

DRWRL  (2 

y 0 ) 

CALL 

MOURL  (“ 

1 y “ 

1 ) 

IF  ( 

IOC  *EQ* 

1 

) 

CALL 

MOURL 

( 

2 t ISCy  3 t ISC  ) 

IF  ( 

IOC  *EG* 

o 

) 

CALL 

MOURL 

✓ 

3 t ISCy  “2  t ISC  ) 

IF  ( 

IOC  ♦EG* 

) 

CALL 

MOURL 

( 

-3  >1^  ISCy  2 t ISC  ) 

IF  ( 

IOC  *EQ* 

4 

) 

CALL 

MOURL 

<“ 

2 lSCy“3  ISC  ) 

CONTINUE 

SITION 

IF  ( 

IOC  ♦EG* 

1) 

CALL  i 

MOURL 

(IS 

Cy“lSC) 

IF  (IOC  *80*  2 ) 
IF  < IOC  .EG.  3) 
IF  < IOC  *EQ*  4) 
RETURN  . 

C GUI  OF  RANGE  OALUE 

9010  WRITE  <6y  9011) 

9011  FORMAT  ( IX" 
RETURN 

END 

END$ 


CALL  MOORL 
CALL  MO'v'RL 
CALL  M0'7RL 


(-ISCy-lSC) 
( ISC  y ISC ) 
(“ISCy  1 S C ) 


DON  ROUTINE  ttt 


OALUE  OUT  OF  RANGE 


“ ) 


i 
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SEIAD  1=00004  IS  ON  CF.’OOOIS  USING  00020  BLKS  R=0000 


0001 

E 

TN4 

0002 

SUBROUTINE  EIAD 

0003 

C 

ENVIRONMENTAL  INPU'l  - 

0004 

C 

0005 

C 

LEUEL  1 

0006 

C 

0007 

C 

EXECUTIVE  FOR  ENVIRONMENTAL  INPUT 

0008 

C 

El AD  IS  ACCESSED  BY  CLAIM  AND  SWAPPED 

0009 

C 

0010 

C 

THE  CALLING  SEQUENCE  IS  ; CALL  EIAD 

0011 

C 

0012 

C 

SUBROUTINES  SCHEDULED: 

0013 

C 

0014 

C 

CAT2 

(CLAIM) 

0015 

C 

CAT3 

(CLAIM) 

0016 

C 

CAT4 

(CLAIM) 

0017 

c 

CAT5 

(CLAIM) 

0018 

c 

CAT6 

(CLAIM) 

0019 

c 

CAT7 

(CLAIM) 

0020 

c 

CATS 

(CLAIM) 

0021 

c 

CAT9 

(CLAIM) 

0022 

c 

CATIO 

(CLAIM) 

0023 

c 

ERASE 

(ITEK) 

0024 

c 

HOME 

(llEK) 

0025 

c 

0026 

c 

THIS  ROUTINE  WAS  WRITTEN  BY  GREEN 

0027 

c 

0028 

c 

CLAIM  RELEASE  1.0  - APRIL 

ABBREOIATLD  DISPLAY 


0029  C 

0030  C 

0031  C 

0032  C 

0033  C 

0034  C 
003t5 

0036  C 

0037  C 

0038  C 

0039 

0040  C 

0041  C 

0042  C 

0043 

0044 

0045 

0046 

0047 

0048 

0049  C 

0050  C 

0051  C 

0052 

0053 

0054 


TEKTf>:ONIX  COMMON 


COMMON  ITEK  (45) 

LOGICAL  UNITS  AND  COMMON  LOCATION 
COMMON  IARRY(5) ? IARY2(5) ?LER?LUFyLUL 


POINTERS 


COMMON  EXIT 
COMMON  lOPTN 
COMMON  ISUR(6 
COMMON  MODE 
COMMON  NOUR 
COMMON  NTOP 


? IANM(3) y ICLI (2) y I6ENC3) ? IGRW(5) 
? 10MR<7) y IPNTR  y IS0C(6) y ISUB(S) 
y 1T0P(9)  y l'v'EG(2)  y LEXIT  y LUO 

yNANM  yNCLI  yNGEN  yNGRU 

yNSECTS  yNSOC  yNSUB  yNSUR 

yNU  yNVEG 


GRADING  PARAMETERS 


COMMON  AREA(5)  y BENLEN  ( 5 y 10  ) yBENUKSy  10)  y COGO  y GCPA  ( 5 ) 
COMMON  GRD0BS(5) yHUHT(5y 10) yHUSLl (5y 10) yNSPP(5) y PCEQ19(4) 
COMMON  PERCNT(5y 10) yREHCPY(5) yREH00L(5) y SLOPE (5y 10) y WBP 
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c 

0056  C 

0057  C 

0058 

0059 

0060 

0061  C 

0062  C 

0063  C 

0064 

0065 

0066 

0067  C 

0068  C 

0069  C 

0070 

0071 

0072 

0073  C 

0074  C 

0075  C 

0076 

0077 

0078 

0079 
OOBO 
0081 

0082  C 

0083 

0084 

0085 

0086 

0087 

0088 

0089 

0090 

0091  C 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099  C 

0100 

0101  C 

0102 

0103 

0104 

0105  C 


CATtlGOF^Y  TGXf 


COMMON  ANIM(23yl3) ?CLMA(13?1 
COMMON  0U8D(ll?13)?SBSL(13)y 


• ) y G It  E ^ 
8CEC( 


□713) yGWHy<22y 13) 
3yl3)ySUHY(44yl3) 


COMMON  TF‘SL(49y  13)  yOGTA<15  7l3) 


EXPECTATION  UALUEG 

COMMON  ANIMAL <13y 6) 7CLIMAT(8y6) yGENDES(876) y GRWHYD ( 1 9 y 6 ) 
COMMON  00RBDN(2876) y SOCECN ( 29 y 6 ) y SUBSQI ( 30 y 6 ) y SURH YD < 23 y 6 ) 
COMMON  TOPSOI <33y 6) y MEGETA ( 10 y 6 ) 


CATEGORY  RESPONSES 

COMMON  RANIMA<3) yRCLlMA(2) yRGENIiE(3) yRGRWHY(5) 
COMMON  R0URBD(7y 10) y RS0CEC(6) y RSUBSG ( 8 ) y RSURH Y ( 6 ) 
COMMON  RT0PS0(9) y R0E6ET<2) 

FEASIyTECONyOPUSE  SUBSYSTEM  PARAMETERS 

COMMON  CAAHM  y CABAH  y CABFN ( 3 ) y CABFP ( 3 ) y CABI IM 

COMMON  CABS ( 2 ) y CAC  y CACP  y CABF  y CABH 

COMMON  CADS  y CAEAF  y CAHSAF  y CAHSTS  y CAIP 

COMMON  CAR3FC  y CASF  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y FAOG ( 5 ) y PFSTSP  y PFAC  y RCLTEC ( 29  y 34 ) 

COMMON  TCAR<5) y THICK(lO) y THKTS y T TL < 40 ) 


INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 


EXI T y CLMA  y GDES  y GWH Y y GVBD  y SDSL 
SCEC  y SWH Y y TPSL  y OGTA  y ANI M 
C L I M A T y G E N D E S y G F=:  U H Y D y 0 M R B D N 
SOCECN  y SUBSOI  y SUF\fTiBy  T OF'SOI 
OEGETAy ANIMAL 

RCL I MA  y RGENBE  y RGRWF-{  Y y ROORBD  y RSOCEC 
RSUBSO  y RSURF-I Y y RTOPSO  y ROEGET  y RANI  MA 
RCLTEC yTTL 


INTEGER  COMMON  (1) 
EQUIOALENCE  (COMMON 
EQUIVALENCE  (lARRY 
EQUIVALENCE  (1ARY2 
EQUIVALENCE  (IARY2 
EQUIVALENCE  (1ARY2 
EQUIVALENCE  < 1ARY2 


(l)y  I TEK 
<l)y  LUT) 

(1) y  ISTRK) 

(2) y  I SECT) 

(3) y  ICODE) 
( 4 ) y L E N ) 


(1)  ) 


LOGICAL  LER 


IF  (LER)  CALL  ERASE 
IF  (LER)  CALL  F-iOME 

GOTO ( 1 00 y 200 y 300 y 400 y 500 y 600 y 700 y 800 y 900) 


EXI  T--1 


0106 

0107 

0108 

0109 

0110 


100  CALL  CAT2 

IF  ( EXIT  .EQ*  0 ) RETURN 
LEXIT  1 

IF  (LER)  CALL  ERASE 
IF  (LER)  CALL  FiOME 
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0111 

C 

0112 

200 

CALL  CAT3 

0113 

IF  ( EXIT 

♦ ECK 

0 ) RETURN 

0114 

LEXIT  1 

0115 

IF  (LER) 

CALL 

ERASE 

0116 

IF  (LER) 

CALL 

HOME 

0117 

C 

0118 

300 

CALL  CAT4 

0119 

IF  ( EXIT 

♦ EQ* 

0 ) RETURN 

0120 

LEXIT  = 1 

0121 

IF  (LER) 

CALL 

ERASE 

0122 

IF  (LER) 

CALL 

HOME 

0123 

C 

0124 

400 

IF(LEXIT*EQ*1) 

NU=0 

0125 

CALL  CAT5 

0126 

IF  ( EXIT 

♦ EQ* 

0 ) RETURN 

0127 

LEXIT  = 1 

0128 

IF  (LER) 

CALL 

ERASE 

0129 

IF  (LER) 

CALL 

HOME 

0130 

C 

0131 

500 

CALL  CA  f 6 

0132 

IF  ( EXIT 

♦ EQ* 

0 ) RETURN 

0133 

LEXIT  = 1 

0134 

IF  (LER) 

CALL 

ERASE 

0135 

IF  (LER) 

CALL 

HOME 

0136 

C 

0137 

600 

CALL  CAT7 

0138 

IF  ( EXIT 

* EQ  * 

0 ) RETURN 

0139 

LEXIT  = 1 

0140 

IF  (LER) 

CALL 

ERASE 

0141 

IF  (LER) 

CALL 

HOME 

0142 

C 

0143 

700 

CALL  CA 1 8 

0144 

IF  ( EXIT 

*EQ* 

0 ) RETURN 

0145 

LEXIT  = 1 

0146 

IF  (LER) 

CALL 

ERASE 

0147 

IF  (LER) 

CALL 

HOME 

0148 

C 

0149 

800 

CALL  CAT9 

0150 

IF  ( EXIT 

♦ EQ* 

0 ) RETURN 

0151 

LEXIT  = 1 

0152 

IF  (LER) 

CALL 

ERASE 

0153 

IF  (LER) 

CALL 

H 0 M E 

0154 

C 

0155 

900 

CALL  CATIO 

0156 

RETURN 

0157 

END 

0158  END$ 
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SEIFU  T=00004  IS  ON  CP;:00015  USING  00030  BLKS  P;.’=0000 


0001  FTN4 

0002  subf:outine  eifb 

0003  C ENVIRONMENTAL  INPUT  - FULL  DISPLAY  (EXECUTIVE) 

0004  C 

0005  C LEVEL  1 

0006  C 

0007  C EIFD  IS  SCHEDULED  BY  CLAIM  AND  SNAPPED  IN  BY  PROGRAM  EIFDX 

0008  C 

0009  C THE  CALLING  SEQUENCE  IS  : CALL  EIFD 

0010  C 

0011  C SUBROUTINES  SCHEDULED  ARE  I 

0012  C 


0013 

C 

ANIMA 

(CLAIM) 

0014 

C 

CLIMA 

(CLAIM) 

0015 

C 

ERASE 

(ITEK) 

0016 

C 

GRWHY 

(CLAIM) 

0017 

C 

HOME 

(ITEK) 

0018 

C 

OVRBD 

(CLAIM) 

0019 

C 

SOCEC 

(CLAIM) 

0020 

C 

SUBSO 

(CLAIM) 

0021 

C 

SURHY 

(CLAIM) 

0022 

C 

TOPSO 

(CLAIM) 

0023 

C 

VE6ET 

(CLAIM) 

0024  C 

0025  C THIS  ROUTINE  UAS  WRITTEN  BY  GREEN 

0026  C 

0027  C claim  release  1<0  ~ APRIL  1»  1980 

0028  C 


0030  C 

0031  C 

0032  C 

0033 

0034  C 

0035  C 

0036  C 

0037 

0038  C 

0039  C 

0040  C 

0041 

0042 

0043 

0044 

0045 

0046 

0047  C 

0048  C 

0049  C 

0050 

0051 

0052 

0053  C 

0054  C 


TEKTRONIX  COMMON 


COMMON  ITEK  (45) 


LOGICAL  UNITS  AND  COMMON  LOCATION 


COMMON  1ARRY(5) ?1ARY2(5) yLER?LUFyLUL 


POINTERS 


COMMON  EXIT 


? IANM(3) ?1CLI(2) ?IGEN(3) ?IGRW(5) 


ISUR(6) ? IT0P(9) y 1VEG(2) ?LEXIT 


COMMON  lOPTN  y I0VR<7) y IPNTR 
COMMON 

COMMON  MODE  yNANM 

COMMON  NOVR  yNSECTS 

COMMON  NTOP  y NU 


iS0C(6) y ISUBC8) 


yNCLl 

yNSOC 

yNVEG 


yNGEN 

yNSUB 


yLUO 
y NGRW 
yNSUR 


GRADING  PARAMETERS 

COMMON  AREA(5) y BENLEN ( 5 y 1 0 ) yBENWI (5y 10) y COGO y GCPA ( 5 ) 
COMMON  GRDVBS(5) yHUHT(5y 10) yHWSLI <5y 10) yNBPP(5) y PCEG19(4) 
COMMON  PERCNT(5y 10) yREHCPY<5) y REHVOL ( 5 ) y SLOPE < 5 y 1 0 ) y WBP 


CATEGORY  TEXT 
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005t5 

0056 

0057 

0058 

0059 

0060 

0061 

0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 

0081 

0082 

0083 

0084 

0085 

0086 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 

0101 

0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


C 


C 

C 

C 


C 


C 

C 


C 

C 

C 


c 


c 


c 


c 

c 

c 

c 

c 


COMMON  ANIM(23y 13) ?CLMA(13y 13) y ODES < 1 5 y 1 3 ) y6WHY(22y 13) 
COMMON  00BD(llyl3)ySBSL(13)y  SCEC < 33 y 13 ) y SWHY < 44 y 1 3 ) 
COMMON  TPSL(49y 13) yOGTA(15y 13) 

EXPECTATION  VALUES 


COMMON  ANIMAL(13y6)  y CLIMAX  ( 8 y 6 ) y GENDES  ( 8 y 6 ) y 6F:WHYH  ( 19  y 6 ) 
COMMON  OVRBDN ( 28  y 6 ) y SOCECN ( 29  y 6 ) y SUBSO I < 30  y 6 ) y SUPH YD ( 23  y 6 ) 
COMMON  T0PS0I(33?6) y VEGET A < 10 y 6 ) 


CATEGORY  RESPONSES 

COMMON  RANIMA(3) yRCLlMA(2) yRGENDE(3) yRGRWHY(5) 
COMMON  F\OVRIiD  ( 7 y 1 0 ) y F’.'SOCEC  ( 6 ) y RSUBSO  8 ) y RSURH Y 6 ) 
COMMON  RT0PS0(9) yRVEGET(2) 

FEASIyTECONyOPUSE  SUBSYSTEM  PARAMETERS 

COMMON  CAAHM  y CABAH  y CABFN ( 3 ) y CABFP  < 3 ) y CABHM 

COMMON  CABS ( 2 ) y CAC  y CACP  y CADF  y CADH 

COMMON  CADS  y CAEAF  y CAHSAF  y CAHSTS  y CA I P 

COMMON  CAR3F  C y CASF  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y F A VG ( 5 ) y PFSTSP  y PFAC  y RCLTEC ( 29  y 34 ) 

COMMON  TCAR(5) y THICK(IO) y THKTSyTTL(40) 

I NTEGER  EXIT  y CLMA  y GDES y GWH Y y OVBD y SBSL 
INTEGER  SCEC  y SWHY  y TPSL  y VGTA  y ANIM 
INTEGER  CLIMAX yGENDESyGRWH YD yOVRBDN 
INTEGER  SOCECN y SUBSOI ySURHYDyTOPSOI 
INTEGER  VEGETA y ANIMAL 

INTEGER  RCL I MA  y RGENDE  y RGRWH Y y ROVRBD  y RSOCEC 
INTEGER  RSUBSO  y RSURH Y y RTOPSO  y RVEGET  y RANI MA 
INTEGER  RCLTEC yXTL 


INTEGER  COMMON  <1) 

EQUIVALENCE  (COMMON  <l)y  ITEK 
EQUIVALENCE  (lARRY  (l)y  LUX) 
EQUIVALENCE  (1ARY2  (l)y  ISTRK) 
EQUIVALENCE  (IARY2  (2)y  ISECT) 
EQUIVALENCE  (IARY2M3)y  ICODE) 
EQUIVALENCE  (1ARY2  (4)y  LEN) 


(1)  ) 


LOGICAL  LER 


USER  INPUT  “>  EDIT  CATEGORY 


IF  (MODE  *80*  1)  GOTO  20 

10  IF  (LER)  CALL  ERASE 

IF  (LER)  CALL  HOME 

WRITE  (LUfy  1000) 

15  READ  (LUTy  t)  EXIT 

IF  (EXIT  ♦EQ»  0)  RETURN 

IF  (EXIT  *GE*  1 ♦ANDc  EXIT  *LE»  9)  GOTO  20 
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0111 

0112 

oii;^ 

0114 

0115 

0116 

0117 

0118 

0119 

0120 

0121 

0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 

0161 

0162 

0163 

0164 

0165 

0166 


n n n n n 


C 

C 

C 

C 

C 


C 

C 

C 

C 

C 


C 

C 

C 

C 

C 


C 

C 

c 

c 

c 


c 

c 

c 

c 

c 


WRITE  (LUTf  1100) 

GOTO  15 

20  IF(M0DE*EQ*1)  EXIT=EXIT“1 

GOTO  (100>200y300»400j500»600y?00f 800?900)  EXIT 


CLIMATOLOGY 

100 

CALL  CLIMA 
IF  (EXIT  ♦EQ* 

0)  RETURN 

IF  (MODE  *GT. 
LEXIT  = 1 

1)  GOTO  10 

TOPSOIL 

200 

CALL  TORSO 
IF  (EXIT  ♦EQ* 

0)  RETURN 

IF  (MODE  ♦GT* 
LEXIT  = 1 

1)  GOTO  10 

SUBSOIL 

300 

CALL  SUDSO 
IF  (EXIT  ♦EQ. 

0)  RETURN 

IF  (MODE  *GT* 
LEXIT  = 1 

1)  GOTO  10 

OOERBURDEM 

400 

IF(LEXIT*EQ*1 
CALL  OORBD 

♦AND.MODE.EQ*!)  NU=0 

IF  (EXIT  ♦EQ* 

0)  RETURN 

IF  (MODE  *6T* 

1)  GOTO  10 

LEXIT  = 1 

SURFACE  WATER 

HYDROLOGY 

500 

CALL  SURHY 
IF  (EXIT  ♦EQ* 

0)  RETURN 

IF  (MODE  *GT* 
LEXIT  = 1 

1)  GOTO  10 

GF;:OU^a■^  WATEF^  FIYDROLOGY 


600  CALL  GRWHY 
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0167 

0168 

0169 

0170 

0171 

0172 

0173 

0174 

0175 

0176 

0177 

0178 

0179 

0180 

0181 

0182 

0183 

0184 

0185 

0186 

0187 

0188 

0189 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

0197 

0198 

0199 

0200 

0201 

0202 

0203 

0204 

0205 

0206 

0207 

0208 

0209 

0210 

0211 

0212 

0213 

0214 

0215 

0216 

0217 


IF'  (EXIT  ♦ECU  0)  RETURN 
IF  (NODE  1)  GOTO  10 

LEXIT  = 1 
C 

Q 

C VEGETATION 

Q 

C 

700  CALL  VE6ET 

IF  (EXIT  *ECU  0)  RETURN 
IF  (MODE  *6T*  1)  GOTO  10 
LEXIT  = 1 
C 

C; 

C ANIMALS 

C 

800  CALL  ANIMA 

IF  (EXIT  ♦EQ*  0)  RETURN 
IF  (MODE  *GT.  1)  GOTO  10 
LEXIT  = 1 
C 

0 

C SOCIO  - ECONOMICS 

0 

c 

900  CALL  SOCEC 

' IF  (MODE  ♦GT*  1)  GOTO  10 

RETURN 
C 

0 

C FORMAT  STATEMENTS 

0 

C 

1000  FORMAT  EDIT  MODE  tttW 


> 

5X* 

1 

1 

1 

i 

1 

I 

1 

t 

1 

1 

I 

! 

1 

m 

\ 

N 

> 

5X"0  -> 

EXITV/ 

5X*1  -> 

CLIMATOLOGY*// 

> 

5X'2  -> 

TOPSOIL*// 

5X"3  -> 

SUBSOIL*// 

5X-4  -> 

OVERBURDEN*// 

5X“5  ~> 

SURFACE  UATER  HYDROLOGY*// 

5X'6  -> 

GROUND  HATER  HYDROLOGY*// 

5X"7  -> 

VEGETATION*// 

> 

5X-8  -> 

ANIMALS*// 

> 

5X'9  -> 

SOCIO  - ECONOMICS*// 

> 

5X’ENTEF 

: EDIT  CATEGORY  ->  _*) 

C 

1100  FORMAT  (5X“??  ERROR  tt  RE-INPUT  ->  -") 
END 

END$ 
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XFEASI  r=00004  IS  ON  CR00015  USING  00050  BLKS  R=0335 


0001  FTN4 


0002  SUBROUTINE  FEASI 

0003  C 

0004  C ENOIRONMENTAL  FEASIBILIIY  RANKINGS 


I 0005  C FEASI  IS  CALLED  BY  PROGRAM  CLAIM  TO  DETERMINE  THE 
I 0006  C ENVIRONMENTAL  FEASIBILITY  RANKINGS  FOR  THE  FIVE  STANDARD 
, 0007  C LAND  USE  ALTERNATIVES  AND  THE  “OTHER*  CATEGORY*  THE 

I 0008  C RANKINGS  ARE  FOUND  BY  AVERAGING  THE  EXPECTATION  OF 
; 0009  C SUCCESS  VALUES  ASSOCIATED  WITH  EACH  RESPONSE*  EACH 

, 0010  C RESPONSE  CARRIES  EQUAL  WEIGHT?  EXCEPT  FOR  THE  OVERBURDEN 

0011  C RESPONSES  ? WHICH  ARE  WEIGHTED  ACCORDING  TO  THE  THICKNESS 

0012  C OF  THE  LITHOLOGIC  UNITS*  THE  APPROPRIATE  LAND  USE  ALTERNATIVE 
i 0013  C IS  “FLAGGED"  AND  A SPECIAL  MESSAGE  DISPLAYED  WHEN  A 

I 0014  C SUITABLE  ENVIRONMENTAL  RESPONSE  IS  ENCOUNTERED*  THESE 
I 0015  C MESSAGES  DEAL  WITH  THE  “MANDATORY"  OR  "FORBIDDEN*  LAND  USE 
I 0016  C ALTERNATIVES  AS  DESCRIBED  IN  THE  CLAIM  USER'S  DATABOOK*  THE 
' 0017  C LAND  USE  RANKINGS  ARE  DISPLAYED  IN  DECREASING  ORDER  - FROM 

0018  C “MOST"  FEASIBLE  TO  "LEAST"  FEASIBLE* 

' 0019  C 

0020  C SUBROUTINE  FEASI  IS  SWAPPED  IN  BY  PROGRAM  FEASX 
I 0021  C 

I 0022  C THE  CALLING  SEQUENCE  IS  : CALL  FEASI 

0023  C 

i 0024  C ALL  DATA  REQUIRED  BY  FEASI  IS  PASSED  THROUGH  THE  COMMON  BLOCK* 

I 0025  C NO  USER  INPUTS  ARE  REQUIRED* 

I 0026  C LABEL  COMMON  ALTRN  MUST  BE  DECLARED* 
i 0027  C 

0028  C FEASI  CALLS  THE  HP  REVISED?  PLOT  10  (TCS)  ROUTINES  : 
j 0029  C BELL?  ERASE?  HOME  ? TINPT* 

, 0030  C 

I 0031  C THE  POINTER  "IPNTR"  IS  USED  SUCH  THAT  IF  1?  THE  FEASIBILITY 
' 0032  C RANKINGS  ARE  OUTPUT  TO  THE  LIST  DEVICE  (LUL?  SET 

0033  C IN  CLAIM)?  OR  IF  3?  THE  RANKINGS  ARE  DETERMINED  BUT  NOT 
i 0034  C PRESENTED  (FOR  THE  OPUSE  RUN) 

, 0035  C 

i 0036  C PRINCIPAL  VARIABLES  : 

1 0037  C 

0038  C CMFA  IS  THE  CURRENT  MAXIMUM  FEASIBILITY  AVERAGE 

0039  C-  RFAV6  IS  THE  RANKED  FEASIBILITY  AVERAGES 

0040  C lADD  IS  THE  ADDITION  TO  THE  "I"  INDEX  IN  EACH  EXPECTATION  ARRAY 

0041  C KCEV  IS  THE  CUMULATIVE  EXPECTATION  VALUES  (ALL  BUT  OVERBURDEN) 

0042  C KFLAG  IS  SET  TO  "BLANK"  FOR  NO  FLAG  - AND  FOR  FLAGS 

I 0043  C OAVG  IS  THE  OVERBURDEN  AVERAGES 

0044  C TOC  IS  THE  TOTAL  OVERBURDEN  CONTRIBUTION 

i 0045  C TOTALX  IS  THE  TOTAL  OF  ALL  EXPECTATION  VALUES 

' 0046  C TOTHK  IS  THE  TOTAL  OVERBURDEN  THICKNESS* 

0047  C 

0048  C THIS  ROUTINE  WAS  WRITTEN  BY  EASTMAN  AND  LATER  MODIFIED  BY  GREEN 

0049  C 

0050  C CLAIM  RELEASE  1*0  - APRIL  1?  1980 

0051  C 

0052  C ==  = = = = = =n=::===:=====::u:===n=:=====::=======:  = ==  = =:  = =:  = =======:=.  = ==  = z.r:=:  = = =============n====  = ===.=:=======. 

0053  C 

0054  C TEKTRONIX  COMMON 
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COMMON  ITEK  (45) 


0055  C 

0056 

0057  C 

0058  C 

0059  C 

0060 

0061  C 

0062  C 

0063  C 

0064 

0065 

0066 

0067 

0068 

0069 

0070  C 

0071  C 

0072  C 

0073 

0074 

0075 

0076  C 

0077  C 

0078  C 

0079 

0080 
0081 

0082  C 

0083  C 

0084  C 

0085 

0086 

0087 

0088  C 

0089  C 

0090  C 

0091 

0092 

0093 

0094  C 

0095  C 
. 0096  C 

0097 

0098 

0099 

0100 
0101 
0102 

0103  C 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


LOGICAL  UNITS  AND  COMMON  LOCATION 
COMMON  IARRY(5) »IARY2(5) >LER»LUF>LUL 
POINTERS 

COMMON  EXIT  » I ANM ( 3 ) j ICLI ( 2 ) ? IGEN ( 3 ) » IGRW ( 5 ) 

COMMON  I OPTN  » lOOR ( 7 ) » I PNTR  ? 1 SOC (6)^1 SUB ( 8 ) 

COMMON  ISUR(6)  j 1T0P(9)  > I VL'G  ( 2 ) » LEXIT  ,LUO 

COMMON  MODE  jNANM  »NCLI  »NGEN  »N6RW 

COMMON  NOOR  yNSECTS  >NSOC  jNSUB  >NSUR 

COMMON  NfOP  fHU  >NUEG 

GRADING  PARAMEIERS 

COMMON  AREA ( 5 ) ? BENLEN ( 5 j 1 0 ) » BENWI ( 5 y 1 0 ) j COGO  ? GCPA ( 5 ) 
COMMON  GRDUBS(5) yHWHT(5y 10) y HWSLI ( 5 y 1 0 ) y NSPP ( 5 ) y PCEQl 9 ( 4 ) 
COMMON  PERCNT ( 5 y 1 0 ) y REHCP Y ( 5 ) y REHOOL ( 5 ) y SLOPE  < 5 y 1 0 ) y WBP 

CATEGORY  TEXT 

COMMON  ANIM(23y 13) yCLMA(13y 13) yGDES( 15y 13) y6WHY(22y 13) 
COMMON  OOBDdl  y 13)  ySBSL(13)  y SCEC  ( 33  y 13 ) y SUHY  ( 44  y 1 3 ) 

COMMON  TPSL(49y 13) y06TA(15y 13) 

EXPECTATION  VALUES 

COMMON  ANIMAL(13y6) yCLIMAT(8y6) yGENDES(8y6) y GRWHYD ( 19 ? 6 ) 
COMMON  0VRBDN(2Sy 6) y S0CECN(29y6) y SUBSOI ( 30 y 6 ) y SURHYD ( 23 y 6 ) 
COMMON  T0PS0I(33y6) yVEGETA(10y6) 

CATEGORY  RESPONSES 

COMMON  RANIMA(3) y RCLIMA < 2 ) y RGENDE ( 3 ) yRGRWHY(5) 

COMMON  R0VRBD(7y 10) y RSOCEC ( 6 ) y RSUBSO ( 8 ) y RSURHY ( 6 ) 

COMMON  RT0PS0(9) yRVE6ET(2) 

FEASI y TECONyOPUSE  SUBSYSTEM  PARAMETERS 

COMMON  CAAHMyCABAHy CABFN(3) yCABFP(3) yCABHM 

COMMON  CABS ( 2 ) y CAC  y CACP  y CADF  y CADH 

COMMON  CADS  y CAEAF  y CAHSAF  y CAHSTS  y CAIP 

COMMON  CAR3FC  y CASF  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y FAVG  < 5 ) y PFSTSP  y PFAC  y RCLTEC ( 29  y 34 ) 

COMMON  TCARC5) yTHICK(lO) y THKTS y TTL ( 40 ) 

INTEGER  EXI T y CLMA y GDES  y GWH Y y OVBD  y SBSL 
INTEGER  SCEC  y SWHY  y TPSL  y VGTA  y ANI M 
INTEGER  CLIMATy GENDESy GRWHYDyOVRBDN 
INTEGER  SOCECN y SUBSOI y SURHYD yfOPSOI 
INTEGER  VEGE  f Ay  ANIMAL 

INTEGER  RCLIMA  y RGENDE  y RGRWHY  y ROVRBD  y RSOCEC 
INTEGER  RSUBSO  y RSURHY  y RTOPSG  y RVEGET  y RANI MA 
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0111  INTEGER  RCLTECjTTL 

0112  C 

0113  INTEGER  COMMON  (1) 

0114  EQUIVALENCE  (COMMON  (1)?  ITEK  (D) 

OllU  EQUIVALENCE  (lARRY  (1)»  LUT) 

0116  EQUIVALENCE  (IARY2  (1)>  ISTRK) 

0117  EQUIVALENCE  (IARY2  (2)t  ISECT) 

' 0118  EQUIVALENCE  (IARY2  (3),  ICODE) 

0119  EQUIVALENCE  (IARY2  (4),  LEN) 

0120  C 

' 0121  LOGICAL  LER 

0122  C 

I 0123  C = = = = = = = = = = = = 

0124  C 

i 0125  COMMON  /ALTRN/  ALTN 

I 0126  INTEGER  ALTN(6j4) 

0127  C 

0128  IiIMENSION  OAVG(IO) > TOC ( 10 ) y RFAVG C 6 ) jKCEV(6) yT0TALX(6) yKFLAG(2) 

■ 0129  DATA  KCEV/OrOy Oy Oy OyO/  y KFLAG/2H 

' 0130  C START  WITH  CROPLAND  AND  PROCEED  THROUGH  THE  'OTHER"  CATEGORY 

' 0131  DO  500  LU0=ly6 

0132  T0TALX(LU0)=0* 

0133  C GENERAL  DESCRIPTION 

I 0134  IADD---0 

0135  DO  20  JJ=lyNGEN 

0136  KCEV(LUO)  = KCEV(LUO)  + GENDES ( RGENDE ( JJ ) +I ADD y LUO ) 

0137  lADD  = lADD  + IGEN(JJ) 

' 0138  20  CONTINUE 

, 0139  C CLIMATOLOGY 

0140  IADD=n0 

' 0141  DO  30  JJ=lyNCLI 

■ 0142  KCEV(LUO)  = KCEV(LUO)  T CLIMAT ( RCLIMA ( JJ ) +I ADDy LUO ) 

I 0143  I ADD  = I ADD  + ICLI(JJ) 

0144  30  CONTINUE 

0145  C TOPSOIL 

I 0146  lADD  ==  0 

0147  DO  40  JJ=lyNTOP 

^ 0148  KCEV(LUO)  = KCEV(LUO)  + TOPSOI (RTOPSOC JJ)+IADDy LUO) 

0149  lADD  = lADD  + ITOP(JJ) 

0150  40  CONTINUE 

0151  C SUBSOIL 

0152  I ADD  = 0 

0153  DO  50  JJ=lyNSUB 

0154  KCEV(LUO)  = KCEV(LUO)  + SUBSOI (RSUBSO< JJ)+IADDy LUO) 

‘ 0155  lADD  lADD  T ISUB(JJ) 

0156  50  CONTINUE 

; 0157  C OVERBURDEN 

0158  I ADD  = 0 

' 0159  TOTTHK  = 0* 

0160  TOC  (LUO)  = 0. 

0161  DO  70  I ==  ly  NOVR 

0162  0AV6  (I)  = 0* 

0163  70  TOTTHK  = TOTTHK  T THICK  (I) 

0164  DO  80  II  = ly  NOVR 

0165  DO  75  JJ  = ly  NU 

0166  75  OAVG  (II)  ==0A  VG  ( 1 1 ) -K  OVRBDN  ( ROVRBD  ( 1 1 y J J ) T I ADD  y LUO  ) )(FrHI  CK  ( J J ) ) 
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0167 

0168 

0169 

0170 

0171 

0172 

0173 

0174 

0175 

0176 

0177 

0178 

0179 

0180 

0181 

0182 

0183 

0184 

0185 

0186 

0187 

0188 

0189 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

0197 

0198 

0199 

0200 

0201 

0202 

0203 

0204 

0205 

0206 

0207 

0208 

0209 

0210 

0211 

0212 

0213 

0214 

0215 

0216 

0217 

0218 

0219 

0220 

0221 

V/  Am 


OAOG  (II)  = OAOG  (II)  / TOTTHK 
TOC  (LUO)  ==  TOC  (LUO)  + OAUG  (II) 

80  I ADD  =-•  I ADD  + lOUR  (II) 

C SURFACE  WATER  HYDROLOGY 

I ADD  = 0 

DO  90  JJ=1jNSUR 

KCEO(LUO)  = KCEO(LUO)  + SURHYD ( RSURHY ( J J ) +I ADD , LUO ) 

I ADD  = I ADD  + ISUR(JJ) 

90  CONTINUE 

C GROUND  WATER  HYDROLOGY 

lADD  = 0 

DO  100  JJ=1jN6RW 

KCEO(LUO)  = KCEO(LUO)  + GRWHYD  ( RGRWHY  ( JJ ) -f  I ADD  > LUO ) 
lADD  = I ADD  + IGRW(JJ) 

100  CONTINUE 

C VEGETATION 

I ADD  =0 

DO  110  JJ=1>NVEG 

KCEV(LUO)  = KCEV(LUO)  + VEGETA(RVEGET( JJ)+IADD»LUO) 

I ADD  = I ADD  + IVEG(JJ) 

110  CONTINUE 

C ANIMAL 

lADD  = 0 

' DO  120  JJ^IjNANM 

KCEV(LUO)  = KCEV(LUO)  + ANIMAL (RANIHA (JJ )+I ADD? LUO ) 

I ADD  = I ADD  + lANM(JJ) 

120  CONTINUE 

C SOCIO-ECONOMICS 

I ADD  = 0 

DO  130  JJ=1,NS0C 

KCEV(LUO)  = KCEV(LUO)  + SOCECN ( RSOCEC ( JJ ) +I ADD » LUO ) 

I ADD  = I ADD  + ISOC(JJ) 

130  CONTINUE 
C 

500  CONTINUE 

C COMPUTE  THE  AVERAGES  FROM  TOTALS 

DO  510  1=1 j 6 

TOTALX(l)  = FLOAT(KCEVd)  ) + TOC  (1) 

510  RFAVG(I)  = TOTALX(I)  / (NGEN  i NCLI  + NTOP  + NSUB  + NOVR  + 


SNSUR  + NGRW  NVE6  -f  NANM  -f  NSOC  ) 

C STORE  THE  UNRANKED  FEASIBILITY  AVERAGES  IN  THE  COMMON  BLOCK 

DO  520  1=1 y 5 

520  FAVG(I)  = RFAVG(I) 

C NOW  ARRANGE  AND  PRINT  OUT  THE  AVERAGES  IN  DESCENDING  ORDER  : 

C IPNTR=3  MEANS  THAT  WE'RE  DONE 


IF(1PNTR*EQ*3)  RETURN 
IF(LER. AND»LUL*EQ*LUT)  CALL  ERASE 
IF(LER*AND^LUL*ELULUT)  CALL  HOME 
J=1 

WRITE(LULy 1000)  TTL 
550  IMAX=1 

C FIND  THE  MAXIMUM  FEASIBILITY  AVERAGE 

CMEA=AMAX1(RFAVG(1) jRFAVG(2) >RFAVG(3) ?RFAV6(4) tRFAVG(5) tRFAVGC 
560  IF(RFAVGdMAX)  *EQ*CMFA)  GOTO  570 
1MAX=IMAX+1 
GOTO  560 
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0223  C BRANCH  TO  THE  APPROPRIATE  SEGMENT  FOR  FLAG  CHECKS 

0224  570  1J=1 

0225  G0T0(600,610,620»630, 640,650)  IMAX 

0226  C CROPLAND  FLAGS: 

0227  C GENERAL  SLOPE  OF  10  RANDOM  POINTS  > 5*7  DEGREES 

0228  C SALINITY  OF  TOPSOIL  > 16  MMHOS/CM 

0229  C PRIME  AGRICULTURAL  LAND 

0230  600  IF(RGENDE(3) ♦ EQ . 3 ♦ OR ♦ RTOPSO < 6 ) ♦EQ»5 

0231  &»0R*RS0CEC<2) ♦ECni)  1J=2 

0232  WRITE(LUL,2100)  J, ( ALTN ( IMAX , K ) , K=1 , 4 ) , CMFA, KFLAG( I J) 

0233  GOTO  670 

0234  C MEGETATION  FLAGS 

0235  C ENDANGERED  PLANT  SPECIES  PRESENT 

0236  610  IF(ROEGET (1) ♦EQ»5)  IJ=2 

0237  URITE(LUL,2100)  J, ( ALTN( 1MAX,K) ,K=1 ,4 ) ,CMFA,KFLAG( I J) 

0238  GOTO  670 

0239  C WILDLIFE  FLAGS 

0240  C ENDANGERED  ANIMAL  SPECIES  PRESENT 

0241  620  IF(RANIMAd)  *EQ*5)  IJ=2 

0242  WRITE(LUL,2100)  J, ( ALTN ( IMAX , K ) , K=1 , 4 ) , CMFA , KFLAG ( I J ) 

0243  GOTO  670 

0244  C WATER  RECREATION  - NO  FLAGS  AT  PRESENT 

0245  630  WRITE(LUL,2100)  J , ( ALTN ( IMAX , K ) , K=1 , 4 ) , CMFA , KFLAG ( 1 J ) 

0246  GOTO  670 

0247  C HIGH  USE  FLAGS 

0248  C ALLUVIUM  PRESENT 

0249  640  IF(RGRWHY(5) .EQ.l)  IJ=2 

0250  WRITE(LUL,2100)  J, ( ALTN < IMAX , K ) , K=1 , 4 ) , CMFA , KFLAG ( I J ) 

0251  GOTO  670 

0252  C OTHER  CATEGORY  - NO  FLAGS 

0253  650  WRITE(LUL,2100)  J , ( ALTN ( IMAX , K ) , K=1 , 4 ) , CMFA , KFLA6 ( I J ) 

0254  C SET  THE  CURRENT  FEASIBILITY  MAXIMUM  TO  -1 

0255  C AND  GET  THE  NEXT  HIGHEST  RANKING 

0256  670  RFAVG(IMAX)  = -1* 

0257  J=J-fl 

0258  1F(J*LE*6)  GOTO  550 

0259  700  WRITE(LUL,2700) 

0260  C 

0261  1000  F0RMATC1",1X,40A2,//,15X'FEASIB1LITY  INDEXES  FOR  THE  CURRENT  * 

0262  . +'DATAV15X,40(  •-•  )/) 

0263  2100  F0RMAT<17X,I1,")  * , 4A2 , 16X , F6 ♦ 3 , IX , A2 ) 

0264  2700  F0RMAT(3/, 1X,70< ■=• )/) 

0265  C 

0266  C EXPLAIN  FLAGS  : 

0267  C AVERAGE  SLOPE  EXCEEDS  5*7  DEGREES  ? 

0268  IF(RGENDE(3) .NE.3)  GOTO  710 

0269  WRITE(LUL,3000) 

0270  3000  FORMAT  (/,3X")f:){=:  YOUR  RESPONSE  TO 

0271  S5X*I.)  GENERAL  DESCRIPTION'/, 

0272  &5X'C*)  AVERAGE  SLOPE  OF  10  RANDOM  POINTS  IN  THE  AREA"/, 

0273  S5X"  WAS > 3.)  5*71  - 11*50  DEGREES*"//, 

0274  &5X"THIS  GENERAL  SLOPE  EXCEEDS  THE  MAXIMUM  REQUIRED  BY  THIS"/, 

0275  J£5X"M0DEL  FOR  THE  CROPLAND  RECLAMATION  ALTERNATIVE*"///) 

0276  C TOPSOIL  SALINITY  EXCEEDS  16  MMHOS/CM  ? 

0277  710  IF(RT0PS0<6) *NE*5)  GOTO  720 

0278  WRITE(LUL,3100) 
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0279 

0280 

0281 

0282 

0283 

0284 

0285 

0286 

0287 

0288 

0289 

0290 

0291 

0292 

0293 

0294 

0295 

0296 

0297 

0298 

0299 

0300 

0301 

0302 

0303 

0304 

0305 

0306 

0307 

0308 

0309 

0310 

0311 

0312 

0313 

0314 

0315 

0316 

0317 

0318 

0319 

0320 

0321 

0322 

0323 

0324 

0325 

0326 

0327 

0328 

0329 

0330 

0331 

0332 

0333 

0334 


3100  FORMAT (/r5X")K)f?  YOUR  RESPONSE  TO  :*/» 

&5X"III*)  TOPSOILVy 
&5X’  F*)  SALINITY"/^ 

X5X"  WAS — > 5.)  16*1  + MMHOS/CM**/) 

WRITE(LUL»3150) 

3150  FORMAT (5X" PRESENT  ENMIRONMEN f AL  AND/OR  LEGAL  CONSTRAINTS " IX 
&-PREOENT  RECLAIMING*/y5X"T0  THIS  LAND  USE  OPTION* IX 
^'UNLESS  SPECIFIC  REMEDIAL  ACTIONS  ARE  TAKEN**///) 

C PRIME  AGRICULTURAL  LAND? 

720  IF(RS0CEC(2) *NE*1)  GOTO  730 
WRITE (LUL» 3200) 

3200  FORMAT (3X-:«)i<  YOUR  RESPONSE  TO  :*/» 

&5X"X*)  SOCIO~ECONOMICS*/j 
X5X"B*)  PRIMARY  PRESENT  LAND  USE*/, 

&5X*  WAS  > 1*)  PRIME  AGRICULTURAL  LAND**/) 

WRITE(LUL?3250) 

3250  F0RMAT(5X"PRESENT  LAWS  INDICATE  THAT  YOU  MUST" IX 
^'RECLAIM  THE  LAND  TO  THIS  0PTI0N"/>5X 
?;*REGARDLESS  OF  THE  FEASIBILITY  RANKING**///) 

C ENDANGERED  PLANT  SPECIES  ? 

730  IF(R0EGET(1) *NE*5)  GOTO  740 
WRITE(LUL>3300) 

3300  FORMAT  (3X")^C)tc  YOUR  RESPONSE  TO  t“/r 
&5X"0III)  NATIVE  VEGETATION*/? 

S5X*  A)  CURRENT  BROAD  PLANT  COMMUNITY  TYPE  PRESENT"/? 

&5X"  WAS  — > THREATENED  OR  ENDANGERED  PLANT  SPECIES  PRESENT*/) 
WRITE(LUL?3250) 

C ENDANGERED  ANIMAL  SPECIES  ? 

740  IF(RANIMAd)  *NE  *5)  GOTO  750 
WR1TE(LUL?3400) 

3400  FORMAT (3X*)|c)^  YOUR  RESPONSE  TO  ***/? 

&5X*IX)  ANIMALS*/? 

S5X*  A)  CURRENT  ABUNDANT  WILDLIFE  TYPES  PRESENT*/? 

&5X*  WAS  — > 5*)  PRESENCE  OF  THREATENED  OR  ENDANGERED " IX 
&*SPECIES*/) 

WRITE(LUL?3250) 

C ALLUVIUM  PRESENT  ? 

750  IF(R6RWHY(5) *NE*1 ) GOTO  755 
WRITE (LUL? 3500) 

3500  FORMAT (3X*:<=:)K  YOUR  RESPONSE  TO  :*/? 

Si5X*VII)  GROUND  WATER  HYDROLOGY*/? 

&5X*  E)  ALLUVIAL  VALLEY  FLOOR*/? 

S5X*  WAS  — > 1*)  PRESENT**/) 

WRITE(LUL?3150) 


C IF  THE  LIST  DEVICE  IS  THE  LINE  PRINTER?  OR  THE  USER'S 

C TERMINAL  DOES  NOT  HAVE  ERASE  CAPABILITY?  WE'RE  DONE* 

C OTHERWISE?  ALLOW  THE  USER  TO  VIEW  THE  TABLE  BEFORE 

C RETURNING* 


755  IF(LUL*NE*LUT*OR* *NOT*LER)  RETURN 
WRITE (LUT? 3510) 

3510  FORMAT(*HIT  THE  RETURN  KEY  TO  CONTINUE  :_*) 
CALL  BELL 
CALL  TINPT(IANS) 

CALL  ERASE 
CALL  HOME 
RETURN 
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0335  END 

0336  ENH$ 
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KTN4 

SUBROUTINE  FIXLN  (SLOPEf PERCNT^ NSPPjKPAIRjLINE) 

C 

C LEVEL  5 
C 

C FIXLN  IS  ACCESSED  BY  DLDCS  TO  FIX  THE  LINE  OF  OUTPUT 
C FOR  THE  SLOPE/PERCENT  TABLE ♦ 

C 

C THE  CALLING  SEQUENCE  IS: 

C 

C CALL  FIXLN  ( SLOPE > PERCN7 j KPAIR ^ LINE ) 

C 

C WHERE 
C 

C SLOPE  IS  THE  FINAL  SLOPE  ARRAY 

C PERCNT  IS  THE  FINAL  PERCENT  ARRAY 

C NSPP  IS  THE  NUMBER  OF  SLOPE/PERCENT  PAIRS  ARRAY 

C KPAIR  IS  THE  CURRENT  SLOPE/PERCENT  PAIR  NUMBER 

C LINE  IS  THE  OUTPUT  LINE 

C 

C SUBROUTINE  CNVRT  IS  CALLED  TO  CONVERT  THE  REAL  NUMBERS 
C CONTAINED  IN  'SLOPE*  AND  'PERCNT"  TO  CHARACTER  REPRESENTATIONS 
C OF  THOSE  NUMBERS 
C 

C "INDEX"  CONTAINS  THE  STARTING  CELLS  FOR  THE  ENTRIES 
C "RVALUE"  IS  THE  CHARACTER  REPRESENTATION  OF  THE  VALUE* 

C 

C THIS  ROUTINE  WAS  WRITTEN  BY  GREEN 
C 

C CLAIM  RELEASE  1*0  - APRIL  1»  1980 

C 

INTEGER  INDEX(5) »NSPP(5) 

INTEGER  LINE<74) rKVALUE(6) 

DIMENSION  SL0PE(5y 10) » PERCNT < 5 y 10 ) 

DATA  INDEX/ly 16y31j46y61/ 

C 

C FIRST? FILL  THE  LINE  WITH  BLANKS 

DO  10  K = 1?  74 
LINE(K)  IH 
10  CONTINUE 

C NOWy  PUT  DASHES  IN  THE  APPROPRIATE  CELLS 

DO  15  K = 8y68yl5 


LINE<R)  = 1H- 

15  CONTINUE 

c 

LOOP  THROUGH 

THE  SLOPE/PERCENI 

VALUES 

c 

AND  SET  THE 

APPROPRIATE  "LINE" 

CELLS 

c 

TO  THE  RETURNED  (FROM  CNVRT)  " 

RVALUE" 

c 

STRING* 

c 

(WE  DON'T  DO 

ANYTHING  IF  NSPP 

IS  USED 

DO  30  R=ly  5 

IF(NSPP(K) *LT*KPAIR)  GOTO  30 

CALL  CNVRT  ( SLOPE < K y KPAI R ) y RVALUE ) 
DO  25  1=1 y 6 

LINE(1NDEX(R)  + I“-1)=RVALUE(I) 
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005'5' 

25 

CONTINUE 

0056 

CALL  CNORT  ( PERCNT  ( K ? KPAIF;:  ) j KOALUE ) 

0057 

DO  27  1=1,6 

0058 

LINE  < I NDEX  ( K ) + 1 + 7 ) =KOALLJE  ( I ) 

0059 

27 

CONTINUE 

0060 

30 

CONTINUE 

0061 

RETURN 

0062 

0063 

END 

*>• 
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FTN4 

SUBROUTINE  FIXSP 

C FIX  SLOPES  AND  PERCENTS  

C 

C LEVEL  4 
C 

C FIXSP  IS  ACCESSED  BY  DLDCS  TO  'FIX"  THE  SLOPE/PERCENT  PAIRS* 
C 

C THE  "FIX"  CONSISTS  THE  THE  FIVE  PHASES: 

C 1*  MAKE  SURE  THAT  FINAL  SLOPES  DO  NOT  EXCEED  THE  INITIAL 

C 2*  MAKE  SURE  THAT  CROPLAND  IS  A VALID  ALTERNATIVE 

C 3*  MAKE  SURE  THAT  THE  FINAL  SLOPE  IS  NOT  LESS  THAN  THE 

C GENERAL  SLOPE* 

C 4*  COMBINE  PERCENTAGES  OF  ADJACENT  EQUAL  SLOPES 

C 5*  GET  RID  OF  EMBEDDED  ZERO  SLOPE/PERCENT  PAIRS* 

C 

C THE  CALLING  SEQUENCE  IS:  CALL  FIXSP 

C 

C THIS  ROUTINE  WAS  WRITTEN  BY  GREEN 
C 

C CLAIM  RELEASE  1*0  - APRIL  1>  1980 

C 
C 
C 
C 


C 

C 

C 

C 

C 

C 


SLOPES 


C 

c 

c 


c 

c 

c 


c 

c 

c 


TEKTRONIX  COMMON 
COMMON  ITEK  (45) 

LOGICAL  UNITS  AND  COMMON  LOCATION 
COMMON  IARRY(5) r I ARY2 ( 5 ) , LER > LUF t LUL 
POINTERS 

COMMON  EXIT  , IANM(3) f ICLI (2) y IGEN<3) ? IGRW(5) 

COMMON  lOPTN  » lOVR ( 7 ) j IPNTR  y ISOC ( 6 ) » ISUB ( 8 ) 

COMMON  ISUR(6) j 1T0P(9) y I VEG ( 2 ) y LEXI T yLUO 
COMMON  MODE  yNANM  yNCLI  ?NGEN  jNGRW 

COMMON  NOVR  yNSECTS  jNSOC  yNSUB  »NSUR 

COMMON  NTOP  yNU  yNVEG 

GRADING  PARAMETERS 

COMMON  AREA ( 5 ) y BENLEN ( 5 y 1 0 ) y BENWI < 5 y 1 0 ) y C060  y 6CPA ( 5 ) 
COMMON  GRDVBS  < 5 ) y HWHT ( 5 y 10 ) y HWSLI ( 5 y 10 ) y NSPP ( 5 ) y PCEQ19 ( 4 ) 
COMMON  PERCNT(5y 10) y REHCPY ( 5 ) y REHVOL ( 5 ) y SLOPE ( 5 y 1 0 ) y WBP 

CATEGORY  TEXT 

COMMON  ANIM(23y  13)  yCLMA(13y  13)  yGDESdSy  13)  y6WHY(22y  13) 
COMMON  0VBD(llyl3)ySBSL(13)y  SCEC ( 33 y 1 3 ) y SWHY ( 44 y 1 3 ) 
COMMON  TPSL ( 49  y 1 3 ) y VGT A ( 1 5 y 1 3 ) 

EXPECTATION  VALUES 
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0055 

0056 

0057 

0058 

0059 

0060 

0061 

0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 

0081 

0082 

0083 

0084 

0085 

0086 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 

0101 

0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


COMMON  ANIMAL<13y6)  yCLIMAT(8»6)  ?GENDES(Sy6)  y GFslvfHYD  ( 1 9 y 6 ) 
COMMON  00RBDN(28»6)  yS0CE-:CN(29,6)  ySUBS0I(30,6)  ? SUKHVD ( 23 » 6 ) 
COMMON  TOPSOI ( 33 » 6 ) f OEGE  f A ( 1 0 » 6 ) 

C 

C CATEGORY  RESPONSES 

C 

COMMON  RANIMA(3) » RCLIMA < 2 ) » RGENDE ( 3 ) » RGRWH Y ( 5 ) 

COMMON  R00RF:D<7> 10) yRS0CEC<6) >RSUBS0(8) jRSURHY(6) 

COMMON  RT0PS0(9) »RMEGET (2) 


C 

C FEASI jTECONjOPUSE  SUBSYSTEM  PARAMETERS 

C 

COMMON  CAAHMyCABAH»CABFN(3) yCABFP(3) ^ CABHM 

COMMON  CABS ( 2 ) y CAC  y CACP  y CADF  y CADH 

COMMON  CADS  y CAEAF  y CAHSAF  y CAHSTS  y CAI P 

COMMON  CAR3FC  y CASE  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  ? FAOG ( 5 ) y PFSTSP  y PF AC  y RCLTEC ( 29  y 34 ) 

COMMON  TCAR(5) yTHICK(lO) y THKTS y TTL ( 40 ) 

C 

INTEGER  EXI T y CLMA  y GDES  y GUH Y y OOBD  y SBSL 
INTEGER  SCEC  y SWH Y y TPSL  y OGTA  y ANI M 
INTEGER  CL  I MAT  y GENDES  y GRk'H YD  y OORBDN 
INTEGER  SOCECNySUBSOI  ySLIRHYDy  rOPSOI 


INTEGER  OEGETAyANIMAL 

INTEGER  RCLIMAyRGENDEyRGRWHYyROVRBDyRSOCEC 
I NTE6ER  RSUBSO  y RSURH Y y RTOPSO  y ROEGET  y RANIMA 
INTEGER  RCLTEC y TTL 
C 

INTEGER  COMMON  (1) 

EQUIVALENCE  (COMMON  (l)y  ITEK  (1)) 
EQUIVALENCE  (lARRY  (l)y  LUT) 

EQUIVALENCE  (IARY2  (l)y  ISTRK) 

EQUIVALENCE  (IARY2  (2)y  ISECT) 

EQUIVALENCE  (IARY2  (3)y  ICODE) 

EQUIVALENCE  (IARY2  (4)y  LEN) 

C 


LOGICAL  LER 


C 


C MAKE  SURE  UE  HAVEN'T  EXCEEDED  THE  INITIAL  SLOPE  ON  ANY 

C OF  OUR  FINAL  SLOPES 

DO  9 K=ly5 

IF(NSPP(K) *EQ.O)  GOTO  9 
DO  6 I=lyNSPP<K) 

IF(RGENDE(2) ♦EQ*3)  GOTO  7 

I F ( SLOPE ( K y 1 ) ♦ GT ♦ GRDVBS ( 2 ) ) SLOPE (Kyi) =GRDVBS ( 2 ) 

GOTO  6 

7 IF(SLOPE(Ky I ) ♦6T*AMIN1 (GRDVBS(4) yGRDVBS(5) ) ) 

>SLOPE(Ky I )=AMIN1 (GRDVBS(4) yGRDVBS(5) ) 

6 CONTINUE 
9 CONTINUE 

C MAKE  SURE  THAT  CROPLAND  IS  AVAILABLE* 

1F(GRDVBS(4) *LE*5*7*0R*NSPP(1) *EQ*0)  GOTO  8 
DO  16  K=lyNSPP(l) 

SL0PE(lyK)=0* 

16  PERCNT(lyK)=0* 
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0111 

0112  C 

0113  C 

0114 

0115 

0116 

0117 

0118 

0119 

0120 
0121 

0122  C 

0123  C 

0124 

0125 

0126 

0127 

0128 


NSPP(1)=0 

MAKE  SURE  THAT  HE 'RE  NOT  GRADING  LESS  THAN  THE 
GENERAL  SLOPE  OF  THE  AREA 
8 IF(R6ENDE<2) ♦EQ^S)  GOTO  19 
DO  21  K=1j5 

IF(NSPP(K) ♦EQ^O)  GOTO  21 
DO  22  I=lyNSPP(K) 

IF(SLOPE(Kf I) ♦6E*GRDVBS(4) ) GOTO  22 
SLOPE (Kyi) =6RD0DS  < 4 ) 

22  CONTINUE 
21  CONTINUE 

COMBINE  PERCENTAGES  OF  EQUAL  SLOPES 
THAT  MAY  HAOE  BEEN  DUPLICATED  ABOOE 
19  DO  13  K=ly5 
ISUBT=0 

IF(NSPP(K) ♦LE^l)  GOTO  13 
DO  12  I=:NSPP<K)  y2y-l 

IF(SLOPE(KyI)*NE*SLOPE(Kyl~l))  GOTO  12 


0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 


PERCNT ( K y I - 1 ) =PERCN  T ( K y I- 1 ) +PERCNT (Kyi) 

SLOPE(Ky I)=0. 

PERCNT(Ky I )=0* 

ISUBT=1SUDT-1 

12  CONTINUE 

NSPP ( K ) =NSPP ( K ) + I SUBT 

13  CONTINUE 

C GET  RID  OF  EMBEDDED  ZERO  SLOPE/PERCENT  PAIRS 

DO  24  K=ly5 

IF(NSPP(K) *LE*1)  GOTO  24 
DO  26  I=lyNSPP(K) 

IF(SLOPE(Ky 1) *GT.O* ) GOTO  26 
DO  27  J=IyNSPP(K)-l 
SLOPE ( K y J ) =SLOPE ( K y JT 1 ) 

PERCNT ( K y J ) =PERCNT ( K y J+ 1 ) 

PERCNT(Ky J+1)=0* 

27  SLOPE(Ky J+1)=0* 

26  CONTINUE 
24  CONTINUE 
RETURN 
END 


END$ 
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FTN4 

SUBROUTINE  GDE 

C GENERAL  DESCRIPTION  EXECUTIVE  

C 

C LEVEL  1 
C 

C GDE  IS  ACCESSED  BY  CLAIM  TO  SCHEDULE  INPUTS  AND  EDITS 
C TO  CATEGORY 
C 

C THE  CALLING  SEQUENCE  IS:  CALL  GDE 

C 

C GDE  SCHEDULES  THE  SUBROUTINES  : 


C 

C 

C 

C 

C 

C 

C 

C 

C GDE 


DLOID  TO  INPUT/EDIT  OPENING  CUT  INITIAL  DATA 
DLMID  TO  INPUT/EDIT  MINE  RUN  INITIAL  DATA 
DLFID  TO  INPUT/EDIT  FINAL  CUT  INITIAL  DATA 
DLGE  TO  GRADE  DRAGLINE  SPOILS 
TSGE  TO  GRADE  TRUCK  AND  SHOVEL  SPOILS 
TSST  TO  UPDATE  TRUCK  AND  SHOVEL  DATA 

USES  THE  TCS  ROUTINES  : ERASE  AND  HOME 


C 

C LOCAL  VARIABLES  ARE  : 

C 

C 'ANS'  - ANSWER  CELL 
C “IANS'  - ANSWER  CELL 
C “ISTA6E“  - PRE-EDIT  MINE  STAGE 


C “ITYPE“  - PRE-EDIT  MINE  TYPE 
C 

C GDE  IS  SWAPPED  IN  BY  PROGRAM  GDEX 
C 

C THIS  ROUTINE  WAS  WRITTEN  BY  GREEN 

C THIS  ROUTINE  WAS  MODIFIED  BY  M<-  LU  SCOTT  ON  6 AUG.  1980. 
C 

C CLAIM  RELEASE  1.0  - APRIL  1>  1980 

C 

C TEKTRONIX  COMMON 

C 

COMMON  ITEK  (45) 

C 

C LOGICAL  UNITS  AND  COMMON  LOCATION 

C 

COMMON  IARRY(5) » I ARY2 ( 5 ) j LER t LUF r LUL 
C 

C POINTERS 

C 

COMMON  EXIT  > I ANM ( 3 ) > ICLI < 2 ) y IGEN ( 3 ) ? IGRW ( 5 ) 

COMMON  lOPTN  , I0VR(7) » IPNTR  , IS0C(6) » ISUB(8) 

COMMON  ISUR(6) j IT0P(9) y 1VEG(2) yLEXIT  yLUO 
COMMON  MODE  yNANM  yNCLI  yNGEM  y NGRW 

COMMON  NOVR  yNSECTS  y NSOC  yNSUB  yNSUR 

COMMON  NTOP  yNU  >NVEG 

C 
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0055  C 

0056  C 

0057 

0058 

0059 

0060  C 

0061  C 

0062  C 

0063 

0064 

0065 

0066  C 

0067  C 

0068  C 

0069 

0070 

0071 

0072  C 

0073  C 

0074  C 

0075 

0076 

0077 

0078  C 

0079  C 

0080  C 

0081 
0082 

0083 

0084 

0085 

0086 

0087  C 

0088 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096  C 

0097 

0098 

0099 

0100 
0101 
0102 

0103 

0104  C 

0105 

0106  C 

0107  C 

0108  C 

0109 

0110 


GRADING  PARAMETERS 

COMMON  AREA(5) tBENLEN(5» 10) »BENWI (5j 10) ,C060?GCPA<5) 

COMMON  GRDVBS(5) >HWHT(5? 10) fHWSLI (5f 10) »NSPP<5) yPCE019(4) 
COMMON  PERCNT ( 5 > 1 0 ) > REHCP Y < 5 ) » REHVOL ( 5 ) > SLOPE ( 5 y 1 0 ) ? WBP 

CATEGORY  TEXT 

COMMON  ANIM(23j 13) f CLMA(13>13) >6DES(15j 13) jGWHY(22j 13) 
COMMON  00BD<ll»13)ySBSL(13)T  SCEC ( 33 y 13) ? SWHY ( 44 ? 13 ) 

COMMON  TPSL(49yl3)yOGTA(15yl3) 

EXPECT>ATION  VALUES 

COMMON  ANIMAL(13y6) yCLIMAT(8y6) y6ENDES(8y6) yGRWHYD(19y6) 
COMMON  0VRBDN(28y6) yS0CECN(29r6) ySUBS0K30y6) ySURHYD(23y6) 
COMMON  T0PS0I(33y6) y VE6ETA(10y6) 

CATEGORY  RESPONSES 

COMMON  RANIMA(3) yRCLIMA(2) y R6ENDE < 3 ) » RGRWH Y ( 5 ) 

COMMON  ROVRBD ( 7 y 1 0 ) y RSOCEC ( 6 ) y RSUBSO ( 8 ) y RSURH Y < 6 ) 

COMMON  RT0PS0(9) yRVEGET(2) 

FEASIyTECONyOPUSE  SUBSYSTEM  PARAMETERS 


COMMON  CAAHMyCABAHyCABFN(3) yCABFP(3) yCABHM 

COMMON  CABS ( 2 ) y CAC  y CACP  y CADF  y CADH 

COMMON  CADS  y CAEAF  y CAHSAF  y CAHSTS  y CAIP 

COMMON  CAR3FC  y CASE  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y FAVG ( 5 ) y PFSTSP  y PFAC  y RCLTEC ( 29  y 34 ) 

COMMON  TCAR<5) y THICK(IO) yTHKTSyTTL<40) 


INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 


EX I T y CLMA  y 6DES  y CUNY  y OVBD  y SBSL 
SCEC  y SWH Y y TPSL  y VGTA  y ANI M 
CL I MAT  y 6ENDES  y GRWHYD  y OVRBDN 
SOCECNy SUBSOI ySURHYDy TOPSOI 
VEGETAyANIMAL 

RCL I MA  y RGENDE  y RGRWH Y y ROVRBD  y RSOCEC 
RSUBSO  y RSURHY  y RTOPSO  y RVEGET  y RANI MA 
RCLTEC yTTL 


INTEGER  COMMON  (1) 


EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 


(COMMON  ( 
(lARRY(l) 
(IARY2(1) 
(IARY2(2) 
(IARY2<3) 
(IARY2(4) 


l)y  IIEK 

y LUT) 
y ISTRK) 
y ISECT) 
y ICODE) 
yLEN) 


(1)) 


LOGICAL  LER 


FOR  INPUT  MODEy  ENSURE  THAT  PREVIOUSLY 
DEFINED  DATA  CANNOT  BE  ACCESSED 
IF(M0DE.EQ*2»0R.M0DE*EQ*3)  GOTO  2 
DO  1 K = ly  5 
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0111 

0112 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120 
0121 
0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 
0161 
0162 

0163 

0164 

0165 

0166 


C 

C 

C 


C 

C 


C 

C 


BRANCH  TO 
TO  20 


10 


NSPP(K)  = 0 
GCPA(K)  = 0* 

CONTINUE 

IF  THE  USER  IS  EDITING  RESPONSES^ 

THE  EDIT  MENU* 

IF  GRADE  SPOILS  ONLY  OPTION?  BRANCH 
IF(M0DE.EQ*2)  GOTO  500 
IF  (MODE*  EG).  4)  GOTO  20 

INPUT  CATEGORY  RESPONSES  TO  GENERAL  DESCRIPTION 
SET  ITYPE  FOR  FUTURE  REFERENCE 
CALL  GENDE 
ITYPE  = RGENDE(l) 

IF  THE  USER  HAS  BEEN  EDITING  EXPECTATIONS?  OR 
IF  HE  WANTS  OUT  OF  THE  INPUT  MODE?  WE'RE  DONE 
IF  ( MODE  * EC)  * 3 * OR  * EXI T * EC)  * 0 ) RETURN 


15 


GOTO (20? 50)  RGENDE(l) 

C DRAGLINE  MINE 

C THEN  SCHEDULE 

lOPTN  = 1 

G0T0(25?30?35)  RGENDE(2) 

CALL  DLOID 

IF(EXIT*EC)*0)  RETURN 
GOTO  40 
CALL  DLMID 

IF(EXIT*EG)*0)  RETURN 
GOTO  40 
CALL  DLFID 

IF(EXIT*EQ.O)  RETURN 
CALL  DLGE 

IF(M0DE*EC)*1)  RETURN 
IF(M0DE*EQ*2)  GOTO  500 

GRADE  SPOILS  ONLY  OPTION* 
IF(LER)  CALL  ERASE 
IF(LER)  CALL  HOME 
WRITE(LUT?2022) 

2022  F0RMAT(/5X*SELECT  ONE  OF  THE 

5X*0-> 


->  INPUT  MINE  DESCRIPTION  PARAMETERS? 
THE  DRAGLINE  GRADING  EXECUTIUE 


20 


25 


30 


35 


40 


•v. 


5X‘l-> 


C 

C 

C 


FOLLOWING  OPTIONS'/ 
EXIT  FROM  THIS  OPTION'/ 

RE-INPUT  INITIAL  DATA'/ 

5X'2->  EDIT  THE  INITIAL  DATA'/ 

5X'3~>  RE-INPUT  FINAL  SLOPES'// 

> 5X'ENTER  YOUR  SELECTION  HERE  ~>  _') 

24  READ(LUT?)fc)  lOPTN 

IF(I0PTN*EC)*0)  RETURN 
IF(I0PTN*EQ*1*0R.I0PTN*EQ*2)  GOTO  22 
IF(I0PTN.EQ*3)  GOTO  40 
WRITE ( LU  f ? 506 ) I OPTN 
GOTO  24 

TRUCK  AND  SHOUEL  MINE  ->  ENTER 


THE 
THE  TRUCK- 


50 

51 


OVERBURDEN? THEN  SCHEDULE 
GRADING  EXECUTIVE 
WRITE(LUT?51) 

FORMAT (/?5X'T')[c)t:  TRUCK  AND  SHOVEL  MINE 

•ENTER  COST  OF  GRADING  SPOILS ( CENTB/CU ♦ YD ) -> 
READ(LUT?)tc)  ANS 

IF(ANS.LT*0. ) RETURN 
COGO=ANS 


COST  OF  GRADING 
AND  SHOVEL 


:f:5X 
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0167 

0168 

0169 

0170 

0171 

0172 

0173 

0174 

0175 

0176 

0177 

0178 

0179 

0180 

0181 

0182 

0183 

0184 

0185 

0186 

0187 

0188 

0189 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

0197 

0198 

0199 

0200 

0201 

0202 

0203 

0204 

0205 

0206 

0207 

0208 

0209 

0210 

0211 

0212 

0213 

0214 

0215 

0216 

0217 

0218 

0219 

0220 

0221 

0222 


55 


56 


57 


RETURN 


C 

C 


60 


500 


LUO  = 1 
lOPTN  = 1 
CALL  TSGE 

IF(NSPP(LUO) ♦EQ*0)  RETURN 
WRITE<LUTj56) 

FORNATC  EXIT  FROM  TRUCK  AND  SHOUEL  ROUTINES  ?(YES  OR  NO)  _•) 
READ(LUT>57)  IANS 
FORMAT <A2) 

IF<IANS*EQ*2HYE) 

LUO  = LUO  + 1 
IF<LUO  *LE*  5 

RESET  MODE  IF  THE  USER  HAS 
TO  A TRUCK  AND  SHOUEL  TYPE 
IF<ITYPE*NE*R6ENDE(1) ) MODE  = 2 
IF(M0DE*EQ»1)  RETURN 

tttEiai  MENU)tc)^3f: 

IF(LER)  CALL  ERASE 
IF(LER)  CALL  HOME 
WRITE(LUT>501) 


55f  60 


CHANGED 

MINE 


FROM  A DRAGLINE 


501 


FORMAT (/ 
*5X*0)  GET 
)K5X"1) 
2t:5X*2) 
)*c5X*3) 
5tc5X“4) 


j5X 


■ Q 


ELECT  ONE  OF  THE  FOLLOWING  OPTIONS 


: •/ 


}»c5X"5) 


ME  OUT  OF  HEREVj 
EDIT  TYPE  OF  MINE"/? 

COST  TO  EXCAUATE  SPOIL*/? 
STAGE  IN  MINING  SEQUENCE*/? 
SLOPE  OF  10  RANDOM  POINTS*/? 
THE  SPOILS  GRADING  DATA*/? 

HERE  ->  -*) 


EDIT 

EDIT 

EDIT 

EDIT 


503 


LE*5) 


510?505 


505 

506 


iilO 


YOUR  SELECTION*~>_* ) 


C 

C 

C 


C 

C 


610 

615 


}f:5X*ENTER  YOUR  SELECTION 
REAIKLUI  ?)^>  lOPTN 

IF  < lOPTN ♦ GE ♦ 0 ♦ AND  * lOPTN 
WRITE(LUT?506)  lOPTN 
F0RMAT(/?5X? 12*?  RE-ENTER 
GOTO  503 

IF(I0PTN*EQ»0)  RETURN 
GOTO <600? 700? 800? 700? 900)  lOPTN 

USER  WANTS  TO  EDIT  THE  TYPE  OF  MINE*  IF  HE  DOES  CHANGE 
THE  TYPE  OF  MINE? THEN  WE  ARE  TEMPORARILY  BACK  IN  THE 
INPUT  MODE  AND  MUST  RE-INPUT  ALL  OF  THE  GRADING  VARIABLES 
RGENDE(l) 

CALL  GENDE 

IF<ITYPE*NE*RGENDE( 1 ) ) 610?500 

USER  HAS  CHANGED  THE  TYPE  OF  MINE  - 
RE-INITIALIZE  GRADING  PARAMETERS 
DO  615  K=128?794 
C0MM0N(K)=0 

IF(R6ENDE(i) *EQ.2)  MODE  = 1 


600  I TYPE 


GOTO 


15 


C 

C 

C 


C 

C 

C 

C 


USER  IS  EITHER  EDITING  THE  COST  TO  EXCAVATE  SPOIL?OR 
THE  SLOPE  OF  10  RANDOM  POINTS  IN  THE  AREA.  THIS  WILL 
HAVE  NO  EFFECT  ON  COSTS  ALREADY  CALCULATED 
700  CALL  GENDE 
GOTO  500 

USER  WANTS  TO  CHANGE  THE  STAGE  IN  MINING  SEQUENCE.  FOR 
THE  DRAGLINE  MINE?WE  HAVE  TO  RE-COMPUTE  THE  GRADING 
COSTS.  THIS  WILL  HAVE  NO  EFFECTT  ON  THE  TRUCK  AND  SHOVEL 
COMPUTATIONS?OTHER  THAN  FOR  REHANDLE  INFORMATION 
800  ISTAGE  = RGENDE(2) 
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0223 

0224 

0225 

0226 

0227 

0228 

0229 

0230 

0231 

0232 

0233 

0234 

0235 

0236 

0237 

0238 

0239 

0240 

0241 

0242 

0243 

0244 

0245 

0246 

0247 

0248 

0249 

0250 

0251 

0252 

0253 

0254 

0255 

0256 

0257 

0258 

0259 


CALL  GENDE 

IF(ISTAGE*NE*R6ENDE<2) ) 810^500 
810  IF<RGENliE(l)  ♦EQ^l)  20 » 820 

820  IF(R6ENDE<2) ♦EQ*1)  830,500 

C USER  HAS  CHANGED  TO  THE  OPENING  CUT  SITUATION  FROM  ONE  OF 

C THE  OTHER  TWO  STAGES*  RE-COMPUTE  THE  GRADING  COSTS  FOR  ALL 

C FIOE  LAND  USE  OPTIONS  AFTER  SETTING  RE-HANDLE  VOLUMES  TO 

C ZERO  (TRUCK  AND  SHOVEL  MINE) 

830  DO  835  LUO  = 1,5 
REHVOL(LUO)  = 0* 
lOPTN  = 2 
835  CALL  TSST 
GOTO  500 

C USER  WANTS  TO  EDIT  THE  MINE  DATA 

900  G0T0(910,950)  RGENDE(l) 

C DRAGLINE  EDIT  SET  lOPTN  TO  2 AND  BRANCH  TO  22 

910  lOPTN  = 2 
GOTO  22 

C TRUCK  AND  SHOVEL  EDIT  GET  LUO  AND  SCHEDULE  TSGE 

950  WRITE(LUT,951 ) 

951  F0RMAT(/,5X"WHICH  LAND  USE  OPTION  DO  YOU  WISH  TO  CONSIDER  ?V, 
Xc5X*0)  NONE'/, 

}((5X'l)  CROPLAND'/, 

}«f5X'2)  NATIVE  VEGETATION'/, 

Jtc5X'3)  WILDLIFE'/, 

5fJ5X'4)  WATER  RECREATION'/, 

)t£5X'5)  HIGH  USE'/, 

)t:5X'ENTER  YOUR  CHOICE  HERE  ->  _') 

READ(LUf,^)  LUO 

IF<LU0*Ea*0)  GOTO  500 
IF(LU0.GE*1*AND*LU0*LE*5)  GOTO  960 
WRITE(LUT,506)  LUO 
GOTO  950 
960  CALL  TSGE 
GOTO  500 
END 
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SGENHE  T=00004  IS  ON  CROOOlt;  USING  00039  BLKS  R=0000 


0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 

0053 

0054 


FTN4 


SUBROUTINE  6ENDE 

GENERAL  DESCRIPTION  CATEGORY  RESPONSES  


LEVEL  2 

6ENDE  IS  ACCESSED  BY  6DE  TO  SCHEDULE  INPUTS  AND  EDITS  TO 
CATEGORY  RESPONSES?  AND  EDITS  TO  EXPECTATION  OF  SUCCESS 
VALUES  TO  CATEGORY  I?  USING  FULL  DISPLAY 


THE  CALLING  SEQUENCE  IS 


GENDE  USES  THE  TCS  ROUTINES  : ERASE  AND  HONE 


C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 
C 

C THIS  ROUTINE  WAS  WRITTEN  BY  GREEN 
C 


CALL  GENDE 


THE  LOCAL  VARIABLES  ARE 


IANS 

II 

I OLD 

LUORN 

NN 


~>  ANSWER  CELL 

~>  "I*  INDEX  CI?J3  TO  GENDES  ARRAY 
~>  PRE-EDIT  CATEGORY  RESPONSE  VALUE 
->  LAND  USE  OPTION  REFERENCE  NUHBER 
->  HEADING  NUHBER 


C CLAIH  RELEASE  1*0  - APRIL  1?  1980 

C 

c 

c 

C TEKTRONIX  COHHON 

C 

COHHON  ITEK  (45) 

C 

C LOGICAL  UNITS  AND  COHHON  LOCATION 

C 

COHHON  IARRY(5) ?IARY2(5) ?LER?LUF?LUL 
C 

C POINTERS 

C 

COHHON  EXIT  ? I ANH ( 3 ) ? ICLI ( 2 ) ? IGEN < 3 ) ? I6RW ( 5 ) 

COHHON  lOPTN  ? lOVR ( 7 ) ? IPNTR  ? IS0C(6) ? ISUB(S) 

COHHON  ISUR(6) ? IT0P(9) ? IVEG(2) ?LEXIT  ?LUO 
COHHON  NODE  ?NANH  ?NCLI  ?NGEN  ?NGRW 

COHHON  NOVR  ?NSECTS  >NSOC  >NSUB  >NSUR 

COHHON  NTOP  ?NU  ?NVEG 

C 

C GRADING  PARAHETERS 

C 

COHHON  AREA<5) ? BENLEN < 5 ? 10 ) ? BENWI ( 5 ? 10 ) ? COGO ? GCPA ( 5 ) 
COHHON  GRDVBS ( 5 ) ? HWHT ( 5 ? 1 0 ) ? HWSL I < 5 ? 1 0 ) ? NSPP ( 5 ) ? PCEQl 9 ( 4 ) 
COHHON  PERCNT ( 5 ? 1 0 ) ? REHCPY ( 5 ) ? REHVOL ( 5 ) ? SLOPE ( 5 ? 1 0 ) ? WBP 
C 

C CATEGORY  TEXT 

C 
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0055 


COMMON  ANIM(23»13) jCLMA(13>13) »GDES(15»13) j6WHY(22f 13) 


0056 

0057 

0058 

0059 

0060 
0061 
0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 
0081 
0082 

0083 

0084 

0085 

0086 
0087 

i 0088 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 
0101 
0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 

1 


c 

c 

c 


c 

c 

c 


c 

c 

c 


c 


c 


c 

c 


c 


COMMON  0UBD<ll!.13)>SBSL(13)y  SCEC  ( 33  y 13 ) > SWHY  ( 44  > 1 3 ) 

COMMON  TPSL(49j13) »06TA<15j13) 

EXPECTATION  VALUES 

COMMON  ANIMAL(13j6) >CLIMAT(8>6) j6ENDES(8j6) y6Rk»HYB(19j6) 
COMMON  OVRBDN SOCECN < 29 » 6 ) y SUBSOI ( 30 y 6 ) y SURH YB ( 23 y 6 ) 
COMMON  T0PS0I(33y6) y VE6ETA(10y6) 

CATEGORY  RESPONSES 

COMMON  RANIMA(3) yRCLIMA(2) y RGENDE ( 3 ) y RGRWHY < 5 ) 

COMMON  R0VRBD(7y 10) yRS0CEC(6) yRSUBS0(8) yRSURHY(6) 

COMMON  RT0PS0(9)yRVEGET(2) 

FEASIyTECONyOPUSE  SUBSYSTEM  PARAMETERS 


COMMON  CAAHMyCABAHyCABFN(3) yCABF"P(3) yCABHM 

COMMON  CABS ( 2 ) y CAC  y C ACP  y CADF  y CABH 

COMMON  CADS  y CAEAF  y CAHSAF  y CAHSTS  y CAIP 

COMMON  CAR3FC  y CASF  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y F A VG ( 5 ) y PFSTSP  y PF AC  y RCLTEC ( 29  y 34 ) 

COMMON  TCAR<5) yTHICK(lO) yTHKISyTTL(40) 


INTEGER  EXI T y CLMA  y GOES  y GWHY  y OVBD y SBSL 
INTEGER  SCECySWHYy TPSLy VGTAyANIM 
INTEGER  CLIMATyGENDESyGRUHYDyOVRBDN 
INTEGER  SOCECN y SUBSOI  ySURHYIiylOPSOI 
INTEGER  VEGETAyANIMAL 

INTEGER  RCL I M A y RGENDE  y R6RWH Y y RO VRED  y RSOCEC 
INTEGER  RSUESOyRSURHYyRTOPSOyRVEGETyRANIMA 
INTEGER  RCLTEC yTTL 


INTEGER  COMMON  (1) 
EQUIVALENCE  (COMMON 
EQUIVALENCE 
EQUIVALENCE 
EQUIVALENCE 
EQUIVALENCE 
EQUIVALENCE 


(lARRY 
(1ARY2 
(IARY2 
(1ARY2  (3)y 
(IARY2^  (4) y 


(1) 

(l)y 

(1)  y 

(2)  y 


y ITEK  (1)) 
LUT) 

ISTRK) 

ISECT) 

I CODE) 

LEN) 


LOGICAL  LER 

DISPLAY  MODE 
1 IF  <*NOT*  LER)  GOTO  5 
CALL  ERASE 
CALL  HOME 

5 GOTO  (10  y20  y30)  MODE 
10  WRITE(LUTy  1010) 

GOTO  40 

20  URITE(LUTy  2010) 

GOTO  40 

30  WRITE(LUfy  3010) 

40  IF  ( MODE  *EQ,  1 ) 45y  47 
45  GOTO  ( lOOy  200y  300  ) LEXIT 
EDIT  MODE- 
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0111 

0112 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120 

0121 

0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 

0161 

0162 

0163 

0164 

0165 

0166 


C 


C 

C 


C 


C 


C 


C 

C 


C 


47  IF  ( MODE  *EQ*  2)  GOTO  < lOOf 150y200>300)  lOPTN 
GOTO  51 

USER  INPUT  ->  EDIT  HEADING 

50  IF  <LER)  CALL  ERASE 
IF  (LER)  CALL  HOME 

51  WRITECLUTj  2020) 

52  f^'EAIKLUTj  2030)  IANS 
IFdANS  ♦EQ,  2HA  ) GOTO  100 
IFdANS  ^EO*  2HB  ) GOTO  200 
IFdANS  *EQ*  2HC  ) GOTO  300 
IFdANS  *EQ*  2HN0)  GOTO  5000 
WRITE<LUT>  1200) 

GOTO  51 

EDIT  EXPECTATIONS  

USER  INPUT  ~>  SUBHEADING  NUMBER 

55  WRITE  (LUTj  3020) 

56  READ  (LUfy  t)  II 
GOTO  90 

USER  INPUT  ~>  LAND  USE  OPTION  REFERENCE  NUMBER 

60  IF(LER)  CALL  ERASE 
IF(LER)  CALL  HOME 
WRITE  <LUT>  3030) 

61  READ  (LUTy  t)  LUORN 

IF  <LUORN  *GE*  1 *ANIU  LUORN  .LE*  6 ) GOTO  65 
WRITE  (LUTj  1200) 

GOTO  61 

!65II=1I+L 

USER  INPUT  ~>  EXPECTATION  VALUE 

70  WRITE  <LUT»  3040) 

71  READ  (LUTf  t)  GENDES  dl>  LUORN) 

IF  (GENDES  (IIjLUORN)  *GE,  0 *AND*  GENDES  dl^LUORN)  *LE.  4) 

♦ GOTO  50 
WRITE  (LUTj  3050) 

GOTO  71 

EDIT  RESPONSES  — 

75  lOLD  ==  RGENDE  (NN) 

77  WRITE  <LUT>  2040)  lOLD 
GOTO  85 

INPUT  RESPONSES  

USER  INPUT  ->  RGENDE  (NN) 

80  WRITE  (LUTt  2000) 

85  READ  (LUTy  t)  RGENDE  (NN) 

II  = RGENDE  (NN) 

IF  (II  ♦ECU  0)  GOTO  (5000t91)  MODE 
90  IF  (II  *GE*  1 ♦AND*  II  ♦LE*  IGEN  (NN))  GOTO  ( 350 » 5001 y 60 ) MODE 


91 


100 


WRITE  (LUTf  1200) 

GOTO  85 

DISPLAY  HEADING  A 

NN  =:  1 
L 0 
J = L -f  1 
WRITE(LUT>  1000) 

WRITE (LUT>  1020) 

WRITE(LUT,  1050) 

WRITE(LUTt  1100) 

WRITE(LUTj  1100) 


(GDES(ld)d  = ld3) 


(GDES(2rI) 
(GDES(3d  ) 
(6DES(4d) 


d3) 


f l==l 
d = ld3) 
d = ly  13) 


dGENDESCl  d ) d = l j6) 
> (GENDES(2d)  d = ld) 
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0167 

0168 

0169 

0170 

0171 

0172 

0173 

0174 

0175 

0176 

0177 

0178 

0179 

0180 

0181 

0182 

0183 

0184 

0185 

0186 

0187 

0188 

0189 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

0197 

0198 

0199 

0200 

0201 

0202 

0203 

0204 

0205 

0206 

0207 

0208 

0209 

0210 

0211 

0212 

0213 

0214 

0215 

0216 

0217 

0218 

0219 

0220 

0221 

V'  Amm 


G0T0<  80 > 75? 


55 


150 

160 


200 


) MODE 
USER  INPUT  ->  COST 
WRITE  (LUT?  2050)  CSTES 
WRITE  (LUT?  1210) 

READ  (LUT?  *)  CSTES 
IF  ( MODE  ♦EQ*  2)  RETURN 

DISPLAY  HEADING  B 

NN  = 2 
L = IGEN  (1) 

J = L + 1 

IF<MODE*NE.l)  GOTO  201 
IF  (LER)  CALL  ERASE 
IF  (LER)  CALL 


TO  EXCAVATE  SPOIL 


201 

WRITE(LUT? 

1000) 

205 

WRITE(LUT? 

1020) 

WRITE (LUT? 

1050) 

WRITE (LUT? 

1050) 

WRITE (LUT? 

1100) 

WRITE (LUT? 

1100) 

WRITE(LUT? 

1100) 

60T0(  80? 

75?  55 

DISPLAY 

300 

IF(MODE  *EQ*  1) 

WRITE(LUT? 

1000) 

303 

WRITE(LUr? 

1020) 

WRITE (LUT? 

1050) 

HOME 

(GDES(1?I)?I=1?13) 

(6DES(5?I)?I==1?13) 
<GDES(6?I) ?I=1?13) 
(GDES(7?I)?I=1j13)? 
(GDES(8?I)*I=1?13)? 
<6DES(9»I)?I=1?13)? 
) MODE 
HEADING  C : 

GOTO  303 

(6DES(1?I)?I=1?13) 


(GENDES(3?I)?I=1?6) 
(GENDES(4?I)?I=--=1?6) 
(GENDES(5r I) ?I=1?6) 


305 


NN  = 3 
L = IGEN 
J = L + 1 
DO  305  K=13?15 
WRITE(LUT?  1100) 
J=J+1 
GOTO  ( 


( (GDES(K?I) ?I=1?13) ?K=10?12) 
(1)  + IGEN  (2) 


(6DES(K?I) ?I=1? 13)? (GENDES( J?I) ?I=1?6) 


350 


IF  ( 
GOTO 


TO  ZERO  AND  RETURN 


5000  EXIT 

5001 


80?  75?  55)  MODE 

INPUT  MODE  DIRECTIONS 
NN  *EQ*  MGEN  ) RETURN 
(160?  300)  NN 

USER  WANTS  OUT  ->  SET  EXIT 

= 0 

RETURN 

FORMAT  STATEMENTS 

1000  FORMAK  13A2  ? 44  ( '•  ){i  * ) ? / ? 26X  ? " ' ? 

?ilOX?  'STANDARD  EXPECTATIONS'  ? IIX?  ':<?'  ?/? 

&26X  ?44(')tc')?/?26X?'  )l?CRrjp)f: ' ? 2X  ? 

&•  NATIVE'  ?2X?  ')«WILD«'  ,2X?  'WATER'  ?3X? 

& • )f:HIGI  |)f:OTHER)(c ' ? / ? 26X  ? 

&')KLAND>J:VE6ETATI0N^LIFE)f:RECREATI0N>kUSE  ' ? 5X  ? ' ' ) 

1020  FORMAT  ( 70 ( •)(?•  ) ?/?26X?  ' * • 4X  " ' lOX ' ' 4X ' ' lOX ' * 4X ' ■i^c  • 5X ' :fc ' ) 

1050  F0RMAT(13A2?  ' * ' ? 4X ? ' ' ? lOX  ? ' • , 4X ? ' ' ? 

&10X?  ')f:'  ?4X?  ?5X?  ) 


1100  F0RMAT(13A2? 
&•){«  'll'  ^ 


'll' 


>ic  'll'  « 


•II 


^ 'll 


II' 


1200  FORMATCYOU  HAVE  TYPED  IN  AN  ILLEGAL  ANSWER* '? 
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0223 

0224 

0225 

0226 

0227 

0228 

0229 

0230 

0231 

0232 

0233 

0234 

0235 

0236 

0237 

0238 

0239 

0240 

0241 

0242 

0243 

0244 

0245 

0246 

0247 

0248 

0249 

0250 

0251 

0252 

0253 

0254 

0255 

0256 

0257 

0258 

0259 

0260 
0261 
0262 
0263 


&/f*GI0E  HER  ANOTHER  SHOT  ~>  _") 

1210> F0RMAT(/-A0ERA6E  COST  TO  EXCAVATE  SPOIL  ( CENTS/CU ♦ YD ♦ ) ->  _") 

2000  FORNAT(  "ENTER  THE  APPROPRI ATE  5X ? 44  , 

^"NUNBERj  OR  ZERO  TO  QUIT  ->  _') 


1010  FORHAT( 


2010  FORNATC 


3010  FORMAT < 


17X" INPUT  RESPONSES/GENERAL  DESCRIPTION"//) 
17X"EDIT  RESPONSES/GENERAL  DESCRIPTION"//) 
17X"EDIT  EXPECTATIONS/GENERAL  DESCRITPION " // ) 


2020  FORMAT<  5X"IN  WHICH  HEADING  IS  YOUR  DESIRED  EDIT  ?"/» 

&5X" (ENTER  A^BjCj  OR  NONE)  ->  _") 

b 

2030  FORMAT (A2) 

b 

2040  FORMAT(  5X"Y0UR  CURRENT  RESPONSE  IS  ->"12?//y 
S5X"ENTER  YOUR  NEW  RESPONSE  HERE  ->  _") 

2050  FORMAT<  5X"C0ST  TO  EXCAVATE  SPOIL  IS  CURRENTLY" F5* 1 > IX 
S"CENTS/CU*  YD*"/) 

b 

3020  FORMAT(  5X"IN  WHICH  SUB-HEADING  IS  THE  EXPECTATION  VALUE"/? 
X5X"Y0U  WISH  TO  CHANGE  ? (ENTER  THE  APPROPRIATE  NUMBER)  ->  .. " ) 

3030  F0RMAT(/5X“SELECT  THE  LAND  USE  OPTION  YOU  WISH  TO  CHANGE"/ 

> IX"  -1-  / -2-  / -3-  / -4-  / -5-  / -6-  /•/ 

> 1X"CR0PLAND/NAT*VEG*/WILDLIFE/WAT*REC*/HIGH  USE/  OTHER/" 
>/5X"ENTER  YOUR  SELECTION  HERE  ->  ^") 

3040  FORMAT(  5X"ENTER  YOUR  NEW  EXPECTATION  VALUE  HERE  ->  _") 

3050  FORMAT  (/?  5X"ERR0R— > YOUR  EXPECTATION  VALUE  MUST  BE"/? 
%5X"0?1?2?3?  OR  4 TO  AVOID  INTRODUCING  A BIAS  ->  _") 


3060  FORMAT(  5X"ANY  MORE  EDITS  TO  GENERAL  DESCRIPTION  ?"/? 
S5X"(YES  OR  NO)  ->  _") 

END 

END^ 


C 


177 


&GETID  T=00004  IS  ON  CR00015  USING  00039  BLKS  R=0000 


0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 

0053 

0054 


FTN4 

C 

SUBROUTINE  GETID 

C GET  INITIAL  DATA 

C 

C LEVEL  1 
C 

C GETID  IS  ACCESSED  BY  CLAIM  TO  INITIALIZE  THE  COMMON  BLOCK* 

C INITIALIZATION  IS  ACHIEVED  BY  READING  THE  FOUR  FILES  : 

C EXPTNSf TEXTECjMLTj  AND  CCFTS* 

C 

C THE  CALLING  SEQUENCE  IS  : CALL  GETID 
C 

C GETID  USES  THE  SYSTEM  ROUTINE  SPOLU  TO  ACCESS  THE  FILES 
C 

C THIS  SUBROUTINE  IS  SWAPPED  IN  BY  PROGRAM  6ETIX 
C 

C THE  LOCAL  VARIABLES  ARE  : 

C 

C CCFTS  ->  3 WORD  ID  SEGMENT  OF  FILE  CCFTS  (INTEGER) 

C EXPTNS  ->  3 WORD  ID  SEGMENT  OF  FILE  EXPTNS  (INTEGER) 

C MLT  ->  3 WORD  ID  SEGMENT  OF  FILE  MLT  (INTEGER) 

C TEXTEC  ~>  3 WORD  ID  SEGMENT  OF  FILE  TEXTEX  (INTEGER) 

C 

C GETID  RETURNS  AN  EXIT  VALUE  OF  -1,  SHOULD  FILE  ACCESS  FAIL* 

C 

C THIS  ROUTINE  WAS  WRITTEN  BY  GREEN/EASTMAN 
C 

C CLAIM  RELEASE  1*0  - APRIL  1>  1980 

C 

C =n  = ==  = ====n:  = = =:  = ==  = ====  = =r===r===:==  = ==============  = z======:===========:=:===:=:===:===================:=:====== 

c 

C TEKTRONIX  COMMON 

C 

COMMON  ITEK  (45) 

C 

C LOGICAL  UNITS  AND  COMMON  LOCATION 

C 

COMMON  IARRY(5) »IARY2(5) yLERjLUFjLUL 
C 

C POINTERS 

C 

COMMON  EXIT  r IANM(3) ? ICLI (2) y IGEN(3) y IGRW(5) 

COMMON  lOPTN  > I0VR(7) » IPNTR  t IS0C(6) y ISUB(8) 

COMMON  ISUR(6) y IT0P(9) y 1VEG(2) y LEXIT  yLUO 
COMMON  MODE  yNANH  yNCLI  yNGEN  yNGRW 

COMMON  NOVR  yNSECTS  yNSOC  yNSUB  yNSUR 

COMMON  NTOP  yNU  yNVEG 

C 

C GRADING  PARAMETERS 

C 

COMMON  AREA(5) yBENLEN(5y 10) yBENWI(5y 10) yC0G0yGCPA(5) 
COMMON  GRDVBS ( 5 ) y HWHT ( 5 y 1 0 ) y HWSL I ( 5 y 1 0 ) y NSPP ( 5 ) y PCEQ 1 9 ( 4 ) 
COMMON  PERCNT(5y 10) y REHCPY ( 5 ) y REHVOL ( 5 ) y SLOPE ( 5 y 10 ) y WBP 
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0055  C 

0056  C 

0057  C 

0058 

0059 

0060 

0061  C 

0062  C 

0063  C 

0064 

0065 

0066 

0067  C 

0068  C 

0069  C 

0070 

0071 

0072 

0073  C 

0074  C 

0075  C 

0076 

0077 

0078 

0079 

0080 
0081 

0082  C 

0083 

0084 

0085 

0086 

0087 

0088 

0089 

0090 

0091  C 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099  C 

0100 

0101  C 

0102 

0103  C 

0104 

0105 

0106 

0107 

0108 

0109  C 

0110 


CATEGORY  TEXT 

COMMON  ANIM(23f 13) »CLMA(13>13) jGDES(15> 13) TGUHY(22r 13) 
COMMON  00BD(llyl3)TSBSL<13) j SCEC ( 33 > 13 ) j SUHY ( 44 ? 13 ) 

COMMON  TPSL(49>13) tOGTA(15t13) 

EXPECTATION  VALUES 

COMMON  ANIMAL<13>6) ?CLIMAT(8y6) yGENDES(8>6) yGRWHYIK19,6) 
COMMON  0VR8DN(28>6) yS0CECN(29?6) jSUBS0I(30j6) jSURHYU(23?6) 
COMMON  T0PS0I(33>6) fVEGETA(10»6) 

CATEGORY  RESPONSES 

COMMON  RANIMA(3) jRCLlMA<2) >RGENDE(3) jRGRWHY<5) 

COMMON  ROVRBD ( 7 > 1 0 ) y RSOCEC ( 6 ) » RSUBSO ( 8 ) » RSURH Y ( 6 ) 

COMMON  RT0PS0(9) jRVEGET<2) 


FEASIf TECONjOPUSE  SUBSYSTEM  PARAMETERS 


COMMON  CAAHM » CABAH  ? CABFN ( 3 ) ? CABFP ( 3 ) j CABHM 

COMMON  CABS ( 2 ) y CAC  y CACP  y CABF  > CADH 

COMMON  CABS  > CAEAF  r CAHSAF , CAHSTS  y CAIP 

COMMON  CAR3FC  y CASF  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y FAVG ( 5 ) y PFSTSP  y PFAC  y RCLTEC  < 29  y 34 ) 

COMMON  TCAR(5) yTHICK(lO) y THKTSyTTL(40) 


INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 


EXI T y CLMA  y 6DES  y GWH Y y OVBD  y SBSL 
SCECySWHYy TPSLy VGTAyANIM 
CLIMAT  y 6ENBES  y 6RWH YB  y OMRBBN 
SOCECN  y SUBSO I y SURHYD  y TOPSOI 
VEGETA y ANIMAL 

RCL I M A y RGENBE  y RGRWH Y y ROVRBB  y RSOCEC 
RSUBSO  y RSURHY  ? RTOPSO  y RVEGE T y RANIMA 
RCLTEC yTTL 


INTEGER  COMMON  (1) 

EQUIVALENCE  (COMMON  (l)y  ITEK  <D) 
EQUIVALENCE  ClARRY  (l)y  LUT) 
EQUIVALENCE  (IARY2  <l)y  ISTRK) 
EQUIVALENCE  (IARY2  (2)y  ISECT) 
EQUIVALENCE  (IARY2  (3)y  ICOBE) 
EQUIVALENCE  (IARY2  <4)y  LEN) 


LOGICAL  LER 


INTEGER  EXPTNS  C3)y  TEXTEC  (3)y  MLT  (3)y  CCFIS  (3) 


BATA  EXPTNS  /2HEX y 2HPT y 2HNS/ 
BATA  TEXTEC  /2HTE y 2HXT y 2HEC/ 
BATA  ICR/15/ 

BATA  MLT  /2HMLy2HT  y 2H  / 
BATA  CCFTS  /2HCC y 2HFT y 2HS  / 

WRITE  (LUfy  2000) 


i79 


0111 

0112 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120 

0121 

0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 

0161 

0162 

0163 

0164 

0165 

0166 


2000  FORMAT  (//5X* HELLO.  I'LL  NEED  A FEW  SECONDS  TO  GET  ORGANIZED...') 
C OPEN  FILE  EXPTNS  (EXPECTATION  OF  SUCCESS  FILE) 

C 

CALL  SPOLU ( LUF  j EXPTNS  j 2 ? 1 y ICR ) 

IF  (LUF  .LT.  0)  GOTO  9000 
C 

C READ  THE  NUMBER  OF  SECTIONS  OF  INFORMATION 

C 

READ(LUFy 1000)  NSECTS 
C 

C READ  THE  NUMBER  OF  HEADINGS  IN  EACH  CATEGORY 

C 


READ (LUF 

y 1010) 

NGENy 

(IGEN(I) 

y 1 = 1 

yNGEN) 

READ (LUF 

y 1010) 

NCLIy 

(ICLKI) 

y 1 = 1 

yNCLI) 

READ (LUF 

y 1010) 

NTOPy 

(ITOP(I) 

y 1 = 1 

yNTOP) 

READ (LUF 

y 1010) 

NSUBy 

(ISUB(I) 

y 1 = 1 

yNSUB) 

READ (LUF 

y 1010) 

NOURy 

(lOOR(I) 

y 1 = 1 

yNOOR) 

READ (LUF 

y 1010) 

NSURy 

(ISUR(I) 

y 1 = 1 

yNSUR) 

READ (LUF 

y 1010) 

NGRWy 

(IGRW(I) 

y 1 = 1 

yNGRW) 

READ (LUF 

y 1010) 

NOEGy 

(lUEG(I) 

y 1 = 1 

yNOEG) 

READ (LUF 

y 1010) 

NANMy 

(lANM(I) 

y 1 = 1 

yNANM) 

READ (LUF 

y 1010) 

NSOCy 

(ISOC(I) 

y 1 = 1 

yNSOC) 

C 

C CATAGORY  1 ->  GENERAL  DESCRIPTION 

C 

K=1 

DO  10  J=lyNGEN 
DO  10  L=lyIGEN(J) 

READ  ( LUF y 1020)  (GENDES(Ky I ) y 1=1 y6) 
K=K+1 

10  CONTINUE 

C CATAGORY  2 ->  CLIMATOLOGY 

C 

K=1 

DO  20J=lyNCLI 
DO  20  L=lyICLI(J) 

READ  ( LUF  y 1020 ) ( CLIMA  T ( K y I ) y 1 = 1 y 6 ) 
K=K+1 

20  CONTINUE 
C 

C CATAGORY  3 ~>  TOPSOIL 

C 

K=1 

DO  30  J=lyNTOP 
DO  30  L=lyITOP(J) 

READ  (LUFyl020)  (TOPSOI  (Kyl)y  I=ly6) 
K=K+1 

30  CONTINUE 
C 

C CATEGORY  4 ->  SUBSOIL 

C 

K=1 

DO  40  J=lyNSUB 
DO  40  L=ly  ISUB(J) 

READ  ( LUF  y 1020 ) ( SUDSO I ( K y I ) y 1 = 1 y 6 ) 
K=KT1 
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0167 

40 

CONTINUE 

0168 

C 

0169 

C 

CATEGORY  5 ->  OVERBURDEN 

0170 

C 

0171 

K=1 

0172 

DO  50  J=1jN0VR 

0173 

DO  50  L=1?10VR(J) 

0174 

READ  <LUE> 1020)  (OVRBDN<K? I ) > 1=1 j 6) 

0175 

K=K+1 

0176 

50 

CONTINUE 

0177 

C 

0178 

C 

CATEGORY  6 ->  SURFACE  WATER  HYDROLOGY 

0179 

C 

0180 

K=1 

0181 

DO  60  J=1jNSUR 

0182 

DO  60  L=1>ISUR(J) 

0183 

READ  ( LUF > 1 020 ) ( SURH YD <KjI)>I  = 1,6) 

0184 

K=K+1 

0185 

60 

CONTINUE 

0186 

C 

0187 

C 

CATEGORY  7 ->  GROUND  WATER  HYDROLOGY 

0188 

C 

0189 

K=1 

0190 

DO  70  J=l>  NGRW 

0191 

DO  70  L=1j  I6RW(J) 

0192 

READ  ( LUF  y 1 020 ) < GRWHYD (Kyl)yl  = ly6) 

0193 

K=K+1 

0194 

70 

CONTINUE 

0195 

C 

0196 

C 

CATEGORY  8 ~>  VEGETATION 

0197 

C 

0198 

K=1 

0199 

DO  80  J=lyNVEG 

0200 

DO  80  L=iy  IVE6<J) 

0201 

READ  <LUFyl020)  < VEGETA ( K y I ) y I=ly6) 

0202 

K=K+1 

0203 

80 

CONTINUE 

0204 

C 

0205 

C 

CATEGORY  9 ~>  ANIMALS 

0206 

C 

0207 

K=1 

0208 

DO  90  J=lyNANM 

0209 

DO  90  L=lyIANM<J) 

0210 

READ  (LUF y 1 020 ) < AN I M AL ( K y I ) y I = 1 y 6 ) 

0211 

K=K+i 

0212 

90 

CONTINUE 

0213 

C 

0214 

C 

CATEGORY  10  ->  SOCIO-ECONOMICS 

0215 

K=1 

0216 

DO  100  J=iyNSOC 

0217 

DO  100  L=lyISOC(J) 

0218 

READ  ( LUF y 1020)  < SOCECN < K y I ) y 1=1 y 6 ) 

0219 

K=K+1 

0220 

100 

CONTINUE 

0221 

C 

0222 

C 

CLOSE  FILE  EXPTNS 
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I 


I 


0223 

022^ 

0225 

0226 

0227 

0228 

0229 

0230 

0231 

0232 

0233 

0234 

0235 

0236 

0237 

0238 

0239 

0240 

0241 

0242 

0243 

0244 

0245 

0246 

0247 

0248 

0249 


C 

CALL  SP0LU<LUK,EXPTNSf2y2»ICR) 

C 

C OPEN  FILE  TEXTEC  (TEXT  FOR  ENVIRONMENTAL  CATEGORIES) 

C 

CALL  SPOLU(LUF»  TEX TEC»2> 1 ? ICR) 

IF  (LUF  *LT*  0)  GOTO  9002 
C 

C READ  IN  THE  TEXT 

C 

READ ( LUF j 1030)  ( ( GDES < K ? 1 ) , 1=1 » 1 3 ) t K=1 » 15 ) y 
((CLMA(K»I)>I  = 1t13)>K=1,13)  j ( (TPSL(Ky  I ) , 1 = 1 > 13)  »K  = 1 j49)  j 
& (SDSLd)  d = lf  13)  f (<OVBD(K>I)  d = lyl3)rK=ldl)> 

X <(SWHY(K>1)  d = ld3)  jK=1  j44)>  (<GWHY(Ky  I)  d = l ? 13)  >K=1 ,22)  ? 

& <(V6TA(K>I)d  = lyl3)yK=lf  15)  j ( ( ANIM(Ky  I ) j 1 = 1 y 13) » K=1  >23)  ? 

& <<SCEC(Kd)fI  = l>13)fK=ly33) 

C 

C CLOSE  FILE  TEXTEC 

C 

CALL  SP0LU(LUFyTEXTEC>2?2j ICR) 

C 

C OPEN  FILE  MLT  (MASTER  LIST  OF  TECHNIQUES) 

C 

WRITE  (LUfy  2001) 

2001  FORMAT  (//5X*JUST  A FEW  SECONDS  MORE****") 

CALL  SP0LU(LUFtMLTj2>1 jICR) 

IF  (LUF  *LT*  0)  GOTO  9004 


0250  C 

0251  C READ  IN  THE  TEXT 

0252  C 

0253  DO  15  1=1 >29 

0254  15  READ(LUF>1040)  (RCLTEC( I > J) > J=1 > 34 ) 

0255  900  CONTINUE 

0256  C 

0257  C CLOSE  FILE  MLT 

0258  C 

0259  CALL  SP0LU(LUF>MLT>2?2> ICR) 

0260  C 

0261  C OPEN  FILE  CCFTS  (COST  AND  CONVERSION  FACTORS  FOR  TECON  SUBSYSTEM) 

0262  C 

0263  CALL  SPOLU( LUF > CCFTS > 2> 1 > ICR) 

0264  IF  (LUF  *LT*  0)  GOTO  9006 


0265 

C 

READ 

IN  THE 

COSTS 

0266 

C 

0267 

READ 

(LUF> 

1050) 

CAAHM 

0268 

READ 

(LUF> 

1050) 

CABAH 

0269 

READ 

(LUF> 

1050) 

CABFN 

(1) 

0270 

READ 

(LUFy 

1050) 

CABFN 

(2) 

0271 

READ 

(LUFy 

1050) 

CABFN 

(3) 

0272 

READ 

(LUFy 

1050) 

CABFP 

(1 ) 

0273 

READ 

(LUFy 

1050) 

CABFP 

(2) 

0274 

READ 

(LUFy 

1050) 

CABFP 

(3) 

0275 

READ 

(LUFy 

1050) 

CABHM 

0276 

READ 

(LUFy 

1050) 

CABS 

(1) 

0277 

READ 

(LUFy 

1050) 

CABS 

(2) 

0278 

READ 

(LUFy 

1050) 

CAC 
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V 


0279 

READ 

(LUF> 

1050) 

CACP 

0280 

READ 

(LUF» 

1050) 

CADF 

0281 

READ 

(LUFj 

1050) 

CADH 

( i 

0282 

READ 

(LUF? 

1050) 

CADS 

..'I 

0283 

READ 

(LUF? 

1050) 

CAEAF 

0284 

READ 

(LUF? 

1050) 

CAHSAF 

('■  ^ 

0285 

READ 

(LUF? 

1050) 

CAHSTS 

— 

0286 

READ 

(LUF? 

1050) 

CAIP 

• '1^ 

0287 

READ 

(LUF? 

1050) 

CAR3FC 

0288 

READ 

(LUF? 

1050) 

CASF 

J 

0289 

READ 

(LUF? 

1050) 

CASNC 

.1 

0290 

READ 

(LUF? 

1050) 

PFSTSP 

C/? 

0291 

0292  C 

READ 

(LUF? 

1050) 

PFAC 

C-: 

0293  C 

CLOSE 

FILE 

CCFTS 

AND  RETURN 

0294 

CALL 

SPOLU 

(LUF? 

CCFTS?2?2?ICR) 

,1 

* 

0295 

RETURN 

r 

J 

c 

iC 

c 


» i 
» I 


-f 


( 


■ ^ 


c 


c 


( 

c. 


0296 

0297 

0298 

0299 

0300 

0301 

0302 

0303 

0304 

0305 

0306 

0307 

0308 

0309 

0310 

0311 

0312 

0313 

0314 

0315 

0316 

0317 

0318 

0319 

0320 

0321 

0322 

0323 

0324 

0325 

0326 

0327 

0328 

0329 

0330 

0331 

0332 


C 

C 

C 


C 

C 

C 

C 


PROCESS  FILE  OPEN  ERRORS 

9000  WRITE  (LUT>  9001)  LUF 

9001  FORMAI  <5X"EXPTNS  FILE  OPEN  ERROR 
EXIT  = -1 

RETURN 

9002  WRITE  (LUTr  9003)  LUF 

9003  FORMAT  <5X“TEXTEC  FILE  OPEN  ERROR 
EXIT  = -1 

RETURN 

9004  WRITE  (LUT>  9005)  LUF 

9005  FORMAT  <5X"MLT  FILE  OPEN  ERROR  ->' 
EXIT  ==  -1 

RETURN 

9006  WRITE  <LUTj  9007)  LUF 

9007  FORMAT  (SX'CCFTS  FILE  OPEN  ERROR  > 
EXIT  = -1 

RETURN 

FORMAT  STATEMENTS 
1000  FORMAT  (12) 

1010  FORMAT  (1012) 

1020  FORMAT  (4X^611) 

1030  FORMAT  (2Xj13A2) 

1040  FORMAT  (9X»34A2) 

1050  FORMAT  (F7*3) 


C 

C 

ENti$ 


END 


183 


->*110) 


->*110) 


110) 


>*110) 


&GRAFS  T=00004  IS  ON  CROOOIS  USING  00024  BLKS  R=0161 


0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 

0053 

0054 


FTN4 

SUBROUTINE  GRAFS 
C 

C LEVEL  4 
C 

C SUBROUTINE  GRAFS  IS  ACCESSED  BY  DLGE  TO 
C DRAW  GRAPHS  OF  THE  FOLLOWING  : 

C 1 : FINAL  SLOPE  MS*  VOLUME  GRADED 

C 2 t FINAL  SLOPE  VS*  TOTAL  COST 

C 3 : FINAL  SLOPE  VS*  FINAL  WIDTH  (OPENING  CUT  OPTION) 

C -OR-  FINAL  SLOPE  VS*  COST/ACRE  (MINE  RUN  % FINAL  CUT  OPTION) 

C GRAPHS  ARE  AVAILABLE  ON  EITHER  THE  TERMINAL  OR  THE  CALCOMP  PLOTTER 
C 

C THE  CALLING  SEQUENCE  IS  : CALL  GRAFS 

C 

C GRAFS  SCHEDULES  THE  SUBROUTINES  : 

C 

C AXES  TO  DRAW  AXES  FOR  THE  GRAPHS 

C DSPLA  TO  DISPLAY  THE  CURRENT  INITIAL  DATA 

C 

C GRAFS  USES  THE  TCS  ROUTINES  I ANMOD y BELL y DRAWA r 
C MOVAB  y MOVE A y SWNDO  y 

C FINTTy  AND  VWNDO 

C AND  THE  SYSTEM  ROUTINES  SETPM  AND  GETLU 
C THIS  ROUTINE  WAS  WRITTEN  BY  EASTMAN/GREEN 
C 

C RELEASE  1*0  - APRIL  ly  1979 

C 

c 

C TEKTRONIX  COMMON 

C 

COMMON  ITEK  (45) 

C 

C LOGICAL  UNITS  AND  COMMON  LOCATION 

C 

COMMON  IARRY(5) y 1ARY2(5) yLERyLUFyLUL 
C 

C POINTERS 

C 

COMMON  EXIT  y I ANM ( 3 ) y ICLI ( 2 ) y IGEN ( 3 ) y IGRW ( 5 ) 

COMMON  lOPTN  y I0VR(7) y IPNTR  y IS0C(6) y ISUB(8) 

COMMON  ISUR(6) y IT0P(9) y 1 VEG ( 2 ) y LEXIT  yLUO 
COMMON  MODE  yNANM  yNCLl  yNGEN  yNGRW 

COMMON  NOVR  yNSECTS  yNSOC  yNSUB  yNSUR 

COMMON  NTOP  yNU  yNVEG 

C 

C GRADING  PARAMETERS 

C 

COMMON  AREA ( 5 ) y BENLEN ( 5 y 1 0 ) y BENW I ( 5 y 1 0 ) y COGO  ? GCPA ( 5 ) 

COMMON  GRDVBS ( 5 ) y HWH T ( 5 y 1 0 ) y HWSL 1 ( 5 y 1 0 ) y NSPP ( 5 ) y PCEQ 1 9 ( 4 ) 

COMMON  PERCNT(5y 10) y REHCPY(5) yREHV0L(5) ySL0PE(5y 10) y WBP 
C 

C CATEGORY  TEXT 
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0055 

0056 

0057 

0058 

0059 

0060 

0061 

0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 

0081 

0082 

0083 

0084 

0085 

0086 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 

0101 

0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


C 


C 

C 

C 


C 

C 

C 


C 

C 

C 


C 


c 


c 

c 

c 

c 


c 

c 


COMMON  ANIM(23, 13) >CLMA(13»13) >GDES(15y 13) ,6WHY(22,13) 
COMMON  00BD(ll>13)>SBSL(13)y  SCEC<33? 13) ySWHY(44, 13) 

COMMON  TPSL(49»13)r06TA(15>13) 

EXPECTATION  VALUES 

COMMON  ANIMAL(13t6) rCLlMAT(8f 6) »6ENDES(8t6) ?6RUHYD(19,6) 
COMMON  0VRBriN<28f 6) yS0CECN<29,6) jSUBSOI (30t6) ySURHYD(23j6) 
COMMON  T0PS0I(33y6) > VEGETA(10j6) 

CATEGORY  RESPONSES 

COMMON  RANIMA(3) jRCLIMA<2) >RGENDE(3) ,R6RWHY(5) 

COMMON  ROVRBD ( 7 ? 1 0 ) t RSOCEC  < 6 ) y RSUBSO ( 8 ) y RSURH Y ( 6 ) 

COMMON  RT0PS0(9) yRVEGET(2) 

FEASIyTECONyOPUSE  SUBSYSTEM  PARAMETERS 


COMMON  CA AHM  y CAB AH  y CABFN  < 3 ) y CABFP ( 3 ) y CABHM 

COMMON  CABS  < 2 ) y CAC  y CACP  y CABF  y C ADH 

COMMON  CADS  y CAEAF  y CANS AF  y CAHSTS  y CA I P 

COMMON  CAR3FC  y CASE  y C ASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y FAVG ( 5 ) y PFSTSP  y PF AC  y RCLTEC ( 29  y 34 ) 

COMMON  TCAR(5) yTHICK(lO) yTHKTSyTTL(40) 


INTEGER 

INTEGER 

INTEGER- 

INTEGER 

INTEGER 

INTEGER 

INTEGER- 

INTEGER 


EXIT  y CLMA  y GDES  y GUH Y y OVBD  y SBSL 
SCEC  y SWHY  y TPSL  y VGTA  y ANIM 
CLI MAT  y GENDES  y GRWH YD  y OVRBDN 
SOCECNy SUBSOI ySURHYDy TOPSOI 
VEGETA y AN I HAL 

RCL I MA  y RGENDE  y R6RUHY  y ROVRBD  y RSOCEC 
RSUBSO  y RSURH Y y RTOPSO  y RVEGET  y RANI MA 
RCLTECy TTL 


INTEGER  COMMON  (1) 


EQUIVALENCE 

(COMMON 

(1) 

y ITEK  (1)) 

EQUIVALENCE 

(lARRY 

(l)y 

LUT) 

EQUIVALENCE 

(IARY2 

(1)  y 

ISTRK) 

EQUIVALENCE 

(IARY2 

(2)  y 

ISECT) 

EQUIVALENCE 

(IARY2 

(3)  y 

I CODE) 

EQUIVALENCE 

(IARY2 

(4)  y 

LEN) 

LOGICAL  LER 

u 

ii 

ii 

ii 

ii 

ii 

ii 

ii 

ii 

ii 

i! 

ii 

!! 

Ii 

ft 

tl 

!! 

i! 

1! 

!! 

tt 

i! 

ii 

ii 

ii 

ii 

ii 

ii 

ii 

Ii 

i! 

ii 

Ii 

Ii 

ii 

Ii 

II 

ii 

i! 

ii 

ii 

12 

!l 

II 

1! 

II 

1! 

!i 

1! 

il 

!! 

tt 

~ ~ 

COMMON  /TABLE/ 

> TBLVy  TBLTy  TBLAy  TBLSy  JCOUNT y TSMIN y KODE y 

> TSMAXyTVMINyTVMAXyTAMINyTAMAXyTTMINyTTMAX 

DIMENSION  TBLVC12) yTBLT(12) yTBLA<12) yTBLS(12) 


IANS  = 2H 
LUD  = LUT 
5 IARRYC3)  = LUD 
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olii 

C 

0112 

C 

FIRST  : FINAL  SLOPE  OS.  VOLUME  GRADED 

0113 

IF(LUD  .EQ.  LUT)  CALL  ERASE 

0114 

IF(LUD  .EQ.  LUT)  CALL  HOME 

0115 

CALL  SWND0(600>300y425»300) 

0116 

CALL  VWNDO(TOMIN,TOMAX-TOMINj TSMIN^TSMAX-TSMIN) 

0117 

CALL  AXES(600s.425y  TOMIN) 

0118 

CALL  M00AD<910y425) 

0119 

CALL  ANMOD 

0120 

WRITECLUDy 1010) 

0121 

CALL  M0MAB<850y400) 

0122 

CALL  ANMOD 

0123 

WRITE(LUDy 1020)  TOMAX 

0124 

CALL  MOOEA(TBLO<l)yTDLS<l)) 

0125 

DO  100  I=2yJC0UNT 

0126 

100 

CALL  DRAWA<TBLO(I) yTBLS(I) ) 

0127 

C 

SECOND  : FINAL  SLOPE  OS  TOTAL  COST 

0128 

CALL  SWND0(600y300y25y300) 

0129 

CALL  OWNDO(TTMINy TTMAX-TTMINyTSMINyTSMAX-ISMIN) 

0130 

CALL  AXES(600y25y TTMIN) 

0131 

CALL  M00AB(910y25) 

0132 

CALL  ANMOD 

0133 

URITE<LUDy 1030) 

0134 

CALL  M00AB(850y5) 

0135 

CALL  ANMOD 

0136 

WRITE(LUDy 1020)  TTMAX 

0137 

CALL  MOOEA(TBLT(l)yTBLS(l)) 

0138 

DO  200  l=--2yJC0UMT 

0139 

200 

CALL  DRAWA(TBLT(I) yTBLS(I) ) 

0140 

C 

THIRD  : FINAL  SLOPE  OS.  WIDTH  (OR  COST  PER  ACRE) 

0141 

CALL  SUND0(S5y300y25y 300) 

0142 

CALL  OWNDO(TAMINy TAMAX"TAMIN>TSMINy TSMAX-TSMIN) 

0143 

CALL  AXES(85y25y TAMIN) 

0144 

CALL  M00AB(390y25) 

0145 

CALL  ANMOD 

0146 

I F < RGENDE ( 2 ) . EQ . 1 ) UR I TE ( LUD  y 1 040 ) 

0147 

IF(RGENDE(2) .NE.l)  WRITE ( LUD y 1041 ) 

0148 

CALL  M00AB(300y5) 

0149 

CALL  ANMOD 

0150 

WRITECLUDy 1020)  TAMAX 

0151 

CALL  M00EA<TBLA(1)VTBLS(D) 

0152 

DO  300  l=2yJC0UNT 

0153 

300 

CALL  DRAUA(TBLA(I)yTBLS(D) 

0154 

CALL  ANMOD 

0155 

CALL  DSPLA 

0156 

C 

PLOTTER  COPY  ? 

0157 

IFdANS  .NE.  2H  ) GOTO  9000 

0158 

WRI TEC LUT y 1050) 

0159 

READ ( LUT y 1060)  IANS 

0160 

IFdANS  .NE.  2HYE)  GOTO  9000 

0161 

WRITECLUTy 1070) 

0162 

READ  ( LUT  y)(0  SIZE 

0163 

IFLAG  = 2 

0164 

CALL  SETPM  (SIZEy IFLAG) 

0165 

CALL  INITT  (LUT) 

0166 

CALL  GETLU  (LUD) 
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0167 

0168 

0169 

0170 

0171 

0172 

0173 

0174 

0175 

0176 

0177 

0178 

0179 

0180 

0181 


GOTO  5 

9000  CALL  FINTT  (0*»0«) 

RETURN 

C FORHAT  STATEMENTS 

1010  FORMATC "00L:CU~YD“ ) 

1020  FORMAT(FlO^l) 

1030  FORMAT ( "COST' ) 

1040  FORMATC "WIDTH" ) 

1041  FORMAT ( "COST/ACRE- ) 

1050  FORMAT (2X" PLOTTER  COPY  ? (YES  OR  NO)  ->  ^") 

1060  FORMAT <A2) 

1070  F0RMAT(2X'PL0T  SIZE  IN  INCHES  ALONG  X AXIS  ->  _") 
C 

END 

END$ 
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SGRWHY  T=-00004  IS  ON  CR00015  USING  00045  BLKS  R=0000 


0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 

0053 

0054 


FTN4 

C 


SUBROUTINE  6RWHY 

FULL  DISPLAY — CATEGORY  7 / GROUND  WATER  HYDROLOGY 


C 

C LEVEL  2 
C 

C GRWHY  IS  ACCESSED  BY  EIFD  TO  SCHEDULE  INPUTS  AND  EDITS  TO 
C CATEGORY  RESPONSES^  AND  EDITS  TO  THE  EXPECTATION  OF  SUCCESS 
C VALUES  FOR  CATEGORY  7 - GROUND  WATER  HYDROLOGY^  USING 
C FULL  DIPLAY 
C 

C THE  CALLING  SEQUENCE  IS  : CALL  6RWHY 

C 

C 6RWHY  USES  THE  TCS  ROUTINES  J ERASE  AND  HOME 
C 

C THE  LOCAL  VA 
C 

C CHN6  ~> 

C IANS  -> 

C II  -*> 

C I OLD  -> 

C LUORN  -> 

C 
C 
C 
C 
C 
C 

C NN  ~> 

C 

C GRWHY  IS  SWAPPED  IN  BY  PROGRAM  GRWHX 
C 

C THIS  ROUTINE  WAS  WRITTEN  BY  GREEN 


lABLES  are: 

ARRAY  CONTAINING  HEADING  LETTER  CHANGES 
ANSWER  CELL 

"I"  INDEX  L (I»J)  3 TO  GRWHYD  ARRAY 
PRE-EDIT  CATEGORY  RESPONSE  VALUE 
LAND  USE  OPTION  REFERENCE  NUMBER 

1- >  CROPLAND 

2- >  NATIVE  VEGETATION 

3- >  WILDLIFE 

4- >  WATER  RECREATION 

5- >  HIGH  USE 

6- >  OTHER 
HEADING  NUMBER 


C 

C CLAIM  RELEASE  liO  - APRIL  1,  1980 

C 

C TEKTRONIX  COMMON  . 

C 

COMMON  ITEK  (45) 

C 

C LOGICAL  UNITS  AND  COMMON  LOCATION 

C 

COMMON  1ARRY(5) y I ARY2 ( 5 ) » LER ? LUF , LUL 
C 

C POINTERS 

C 

COMMON  EXIT  ? I ANM ( 3 ) > ICLI ( 2 ) , I6EN ( 3 ) ^ IGRW < 5 ) 

COMMON  lOPTN  » IOVR< 7 ) , IPNTR  y IS0C(6) y ISUB<8) 


COMMON  ISUR(6) y IT0P(9) y I VE6 ( 2 ) y LEXI T yLUO 


COMMON 

MODE 

yNANM 

yNCLl 

yNGEN 

y NGRW 

COMMON 

NOVR 

yNSECTS  yNSOC 

yNSUB 

yMSUR 

COMMON 

NTOP 

yNU 

yNVEG 

■ 
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0055  C 

0056  C 

0057 

0058 

0059 

0060  C 

0061  C 

0062  C 

0063 

0064 

0065 

0066  C 

0067  C 

0068  C 

0069 

0070 

0071 

0072  C 

0073  C 

0074  C 

0075 

0076 

0077 

0078  C 

0079  C 

0080  C 

0081 
0082 

0083 

0084 

0085 

0086 

0087  C 

0088 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096  C 

0097 

0098 

0099 

0100 
0101 
0102 

0103 

0104  C 

0105 

0106 

0107  C 

0108 

0109  C 

0110  C 


GRADING  PARAMETERS 

COMMON  AREA ( 5 ) r BENLEN (5^10)?  BENW I < 5 y 1 0 ) y C060 » GCPA ( 5 ) 
COMMON  GRDOBS ( 5 ) » HWH T ( 5 j 1 0 ) ^ HWSL I < 5 » 1 0 ) f NSPP ( 5 ) y PCEO 19(4) 
COMMON  PERCNT(5» 10) >REHCPY<5) yREH00L(5) ,SL0PE(5y 10) ,1/BP 

CATEGORY  TEXT 

COMMON  ANIM(23, 13) , CLMA ( 13 , 13 ) , GDES ( 15 , 1 3 ) , 6WHY < 22 , 1 3 ) 
COMMON  00BD(11,13),SBSL(13),  SCEC ( 33 , 13 ) , SUHY ( 44 , 1 3 ) 
COMMON  TPSL(49,13) ,0GTA(15,13) 

EXPECTATION  VALUES 

COMMON  ANIMAL (13,6), CL IMAT (8,6), GENDES (8,6), GRWH YB (19, 
COMMON  OVRBDN (28,6), SOCECN (29,6), SUBSO I (30,6), SURH YB ( 2 
COMMON  TOPSOI (33,6), VEGETA (10,6) 

CATEGORY  RESPONSES 

COMMON  RANIMA(3) ,RCLIMA(2) ,R6ENDE(3) ,RGRUHY(5) 

COMMON  RO VRBD (7,10), RSOCEC ( 6 ) , RSUBSO ( 8 ) , RSURH Y ( 6 ) 

COMMON  RT0PS0(9) ,RVEGET(2) 

FEASI,TECON,OPUSE  SUBSYSTEM  PARAMETERS 

COMMON  CA ARM , C ABAH , C ABFN ( 3 ) , CABFP ( 3 ) , CAHBM 
COMMON  CABS ( 2 ) , CAC , CACP , C ABF , CADH 
COMMON  CADS , CAE AF , CAHSAF , CAHSTS , CAIP 
COMMON  CAR3FC , CASE , CASNC , CSTE6 , CSTRM 
COMMON  CSTRP , F AVG ( 5 ) , PFSTSP , PFAC , RCLTEC ( 29 , 34 ) 

COMMON  TCAR(5) ,THICK(10) ,THKfS,TTL(40) 

I NTE6ER  EXIT, CLMA , GDES , GWH Y , OVBD , SBSL 
INTEGER  SCEC , SUH Y , TPSL , VGT A , ANI M 
INTEGER  CLIMAT, GENDES, GRWHYD,OVRBDN 
INTEGER  SOCECN, SUBSOI ,SURHYD, TOPSOI 
INTEGER  VEGETA, ANIMAL 

INTEGER  RCLI MA , RGENDE , RGRWH Y , ROVRBD , RSOCEC 
INTEGER  RSUBSO , RSURHY , RTOPSO , RVEGET , RANIMA 
INTEGER  RCLTEC, TTL 

INTEGER  COMMON  (1) 

EQUIVALENCE  (COMMON  (1),  ITEK  (D) 

EQUIVALENCE  (lARRY  (1),  LUT) 

EQUIVALENCE  (IARY2  (1),  ISTRK) 

EQUIVALENCE  CIARY2  (2),  ISECT) 

EQUIVALENCE  (IARY2  (3),  ICODE) 

EQUIVALENCE  (1ARY2  (4),  LEN) 

LOGICAL  LER 
INTEGER  CHN6  <2) 

DATA  CHNG/2H  C,2H  D/ 
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nO 


0111 

C 

DISPLAY  MODE 

"te 

0112 

1 

IF  ( .N0T*LER)  GOTO  5 

'81 

0113 

CALL  ERASE 

0114 

CALL  HOME 

0115 

5 

GOTO  ( 10 » 20? 30)  MODE 

0116 

10 

WRITE  (LUTtIOIO) 

i 

0117 

GOTO  40 

0118 

20 

WRITE  <LUT?2010) 

0119 

GOTO  40 

1 

0120 

30 

WRITE  (LUT?3010) 

0121 

40 

IF  ( M0DE\GT*1)  GOTO  50 

J 

0122 

GOTO  (100?200?300?400?500)  LEXIT 

i - '' 

0123 

C 

USER  INPUT  ->  EDIT  HEADING 

- 

0124 

50 

WRITE  (LUT?2020) 

_ •* 

0125 

51 

READ  (LUT?2030)  IANS 

i ’i 

0126 

IF  (IANS»EQ*2HA  ) GOTO  100 

0127 

IF  (IANS*EQ*2HD  ) GOTO  200 

- 

0128 

IF  <IANS*ECK2HC  ) GOTO  300 

0129 

IF  <IANS.EQ*2HD  ) GOTO  400 

^ i' 

0130 

IF  (IANS.EQ*2H£  ) GOTO  500 

0131 

IF  (IANS*EQ*2HN0)  RETURN 

•’! 

( ^ • 

0132 

WRITE  <LUT?1200) 

0133 

GOTO  51 

0134 

C 

EDIT  EXPECTATIONS 

(’  '* 

0135 

C 

USER  INPUT  ->  SUBHEADING  NUMBER 

'■ 

0136 

52 

WRITE  (LUf?3020) 

- ' 

0137 

57 

READ  <LUT?)<c)  II 

/ '? 

0138 

GOTO  85 

0139 

C 

USER  INPUT  ~>  LAND  USE  OPTION  REFERENCE  NUMBER 

■■  - 

0140 

53 

WRITE  (LUT?3030) 

1 ? 
< ' 

0141 

54 

READ  (LUT?){c)  LUORN 

- ? 

0142 

IF  (LUORN. GE. 1 *AND*LU0RN*LE»6)  GOTO  56 

0143 

WRITE  (LUT?1200) 

} 

0144 

GOTO  54 

Iv 

0145 

56 

II  = II  + L 

0146 

C 

USER  INPUT  ~>  EXPECTATION  VALUE 

0147 

58 

WRITE  <LUT?3040) 

0148 

59 

READ  (LUT?)*c)  GRWHYD  <11?  LUORN) 

O ^ M: 

0149 

IF  (GRWHYD  (II?LUORN) .GE.O.AND.GRWHYD  ( I I ? LUORN ) ♦ LE . 4 ) 

0150 

GOTO  600 

- 

0151 

WRITE  <LUT?3050) 

'4 

* i 

0152 

GOTO  59 

( 

0153 

C 

EDIT  RESPONSES 

0154 

60 

lOLD  = RGRWHY  (NN) 

_3 

0155 

65 

WRITE  (LUT?2040)  lOLD 

V 

0156 

GOTO  83  ■ 

0157 

C 

INPUT  RESPONSES 

-* 

0158 

C 

USER  INPUT  ~>  RGRWHY  (NN) 

i. 

0159 

70 

WRITE  (LUT?2000) 

- 

0160 

83 

READ  (LUT?)fr:)  RGRWHY  (NN) 

t 

0161 

IF  (RGRWHY  (NN)<ECnO)  GOTO  (900? 87)  MODE 

L 

0162 

II  = RGRWHY  (NN) 

0163 

85 

IF  (II.GE.l.AND.II.LE.IGRW  (NN))  GOTO  (700?600?53)  MODE 

- 

0164 

87 

WRITE  <LUT?1200) 

t,  ’= 

0165 

GOTO  (83? 83? 57)  MODE 

/} 

0166 

C 

DISPLAY  HEADING  A ->  DEPTH  TO  GROUNDWATER 

I 


I 

I 


I 
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0167 

0168 

0169 

0170 

0171 

0172 

0173 

0174 

0175 

0176 

0177 

0178 

0179 

0180 

0181 

0182 

0183 

0184 

0185 

0186 

0187 

0188 

0189 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

0197 

0198 

0199 

0200 

0201 

0202 

0203 

0204 

0205 

0206 

0207 

0208 

0209 

0210 

0211 

0212 

0213 

0214 

0215 

0216 

0217 

0218 

0219 

0220 

0221 

0222 


100  HH  = 1 


105 

106 
C 

200 


205 


210 

C 

300 


305 

310 


315 

C 

400 


405 


J = 1 

IF(HODE.Nfci:*l*AND*LER)  CALL  ERASE 
IF(M0DE.NE*1*AMIULER)  CALL  HOHE 
WRITE  (LUTy999)  (GWHY  (ItD^I  = 1,13) 

WRITE  (LUT,1000)  (GWHY  (2, I), I = 1,13) 

L = J~1 

WRITE  (LUT,1020) 

WRITE  <LUT,1050)  ( (GWHY  (K,I),I  = 1,13),K  = 3,5) 

DO  105  K ==6,9 

WRITE  (LOT, 1100)  (GWHY  (K,I),I  = 1,13),  (GRWHYD  (J,I),I 
J = J + 1 

GOTO  (70,60,52)  MODE 

DISPLAY  HEADING  B ->  AMOUNT  OF  GROUNDWATER 

NN  = 2 

J =••  IGRW  (1)  -f  1 
L = J-1 


IF  (*NOT*LER) 
CALL  ERASE 
CALL  HOME 
WRITE  (LUT,999) 
WRITE  (LUT,1000) 
WRITE  (LUT,1020) 
WRITE  (LUT,1050) 
DO  210  K = 20,24 
WRITE  (LUT,1100) 
J = J + 1 
GOTO  106 

DISPLAY 


GOTO  205 

(GWHY  (1,1), I = 1,13) 

(GWHY  (2, 1),  I =•■  1,13) 

( (GWHY  (K,I),I  = 1,13),K  = 10 

(SWHY  (K,I),I  = 1,13),  (GRWHYD 

HEADING  C ->  SALINITY 


18) 

( J, I ) , I 


IF  (<-NOT*LER)  GOTO  310 
CALL  ERASE 
CALL  HOME 

WRITE  (LUT,999)  (GWHY  (1,1), I = 1,13) 

WRITE  (LUT,1000)  (GWHY  (2, I), I = 1,13) 

NN  = 3 

J =••  IGRW  (1)  T IGRW  (2)  + 1 
L = J-1 

WRITE  (LUT,1020) 

WRITE  (LUT,1051)  CHNG  (1),  (SWHY  (33, I), I = 3,13) 

WRITE  (LUT,1050)  (SWHY  (34,1), I = 1,13) 

DO  315  K = 35,38 

WRITE  (LUT,1100)  (SWHY  (K,I),I  = 1,13),  (GRWHYD  (J,I),I 
J = J + 1 
GOTO  106 

DISPLAY  HEADING  D ~>  SODIUM  ADSORPTION  RATIO 

NN  = 4 

J = IGRW  (1)  + IGRW  (2)  T IGRW  (3)  T 1 
L = J-1 


IF  (♦NOT*LER)  GOTO  405 
CALL  ERASE 
CALL  HOME 


WRITE  (LUT,999) 
WRITE  (LUT,1000) 
WRITE  (LUT,1020) 
WRITE  (LUT, 1051 ) 
WRITE  (LUT, 1050) 


(GWHY  (1,1), I = 1,13) 

(GWHY  (2, I), I = 1,13) 

CHNG  (2),  (SWHY  (39, I), I = 3,13) 
(SWHY  (40?I),1  = 1,13) 


— 1,6) 


= 1,6) 


= 1,6) 
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0223 

0224 
022^ 
0226 

0227 

0228 

0229 

0230 

0231 

0232 

0233 

0234 

0235 

0236 

0237 

0238 

0239 

0240 

0241 

0242 

0243 

0244 

0245 

0246 

0247 
024  8 

0249 

0250 

0251 

0252 

0253 

0254 

0255 

0256 

0257 

0258 

0259 

0260 
0261 
0262 

0263 

0264 

0265 

0266 

0267 

0268 

0269 

0270 

0271 

0272 

0273 

0274 

0275 

0276 

0277 

0278 


lrl3)»  (GFn’WHYD  (JjDtI 


1 j6) 


DO  410  K =:  41y44 
WRITE  (LUTyllOO)  (SWHY  (Kyl)yl 
410  J = J + 1 
GOTO  106 

C DISPLAY  HEADING  E ->  ALLUOIAL  OALLEY  FLOOR 

500  NN  = 5 

J = IGRW  (1)  + I6RW  (2)  + I6RW  (3)  T IGRW  (3)  T 1 
L = J“1 

IF  (tHOT^LER)  GOTO  505 
CALL  ERASE 
CALL  HOME- 

WRITE  (LUfy999)  (GWHY  (lyl)yl  = lyl3) 

WRITE  (LUTjIOOO)  (GWHY  (2? I)? I = 1j13) 

505  WRITE  ( LOT y 1020) 

WRITE  (LUTylOSO)  ( (GWHY  (Kyl)yl  = lyl3)yK  =•*  19y20) 

DO  510  K = 21y22 

WRITE  (LUTyllOO)  (GWHY  (Kyl)yl  = lyl3)y  (GRWHYD  (Jyl)yl  = ly6) 
510  J = J + 1 
GOTO  106 

C USER  INPUT  ->  MORE  EDITS  ? 

600  WRITE  (LUTy3060) 

READ  (LUTy2030)  IANS 

IF  (IANS«NE*2HYE)  RETURN 
GOTO  1 

C INPUT  MODE  ->  DIRECT  TO  PROPER  HEADING 

700  IF  (NN.ECKN6RW)  RETURN 
GOTO  (200y 300y400y500)  NN 

C USER  WANTS  OUT  ->  SET  EXIT  TO  ZERO  AND  RE'FURN 

900  EXIT  ==  0 
RETURN 

C FORMAT  STATEMENTS 

999  FORMAT  ( 13A2) 

C 

1000  FORMAT  (13A2y44  ( * * ) y / y 26X  y * ' y 

XlOXy  'STANDARD  EXPECTATIONS"  y 1 1 X y " " y / y 
&26Xy  44  ( "Xc"  ) y/y26Xy  “ XcCROPXc  “ y2Xy 
&"NATIOE"  y2Xy  ")F:WILDXc"  y2X?  "WATER"  y3Xy 
&"5KHI6H)SOTHER:^:"  y/y26Xy 

g"XcLAND)F:OEGETATION-«:LIFEXcRECREATION)fcUSE  y5Xy  "Xi"  ) 

C 

1020  FORMAT  (70  ( " Xc " ) y / y 26X y " Xc  • 4X " * lOX  * "4X " Xc " lOX " X: " 4X " X^ " 5X " " ) 

C 

1050  FORMAT  ( 13A2y "X" y 4Xy "X" y lOXy "X" y4Xy "X" y 
glOXy  "X"  y 4Xy  " X " y 5X y " X " ) 

C 

1051  FORMAT  ( 2Xy A2 y 1 1 A2 y " X " y 4X y “ X " y lOX y “ X " y 4X y " X " y 
SlOXy "X" y4Xy "X" ySXy "X" ) 

C 

1100  FORMAT  (13A2y 

&"X  "II"  X "II"  X "I1"X  "11“  X“I1 

C 

1200  FORMAT  (/"YOU  HAVE  TYPED  IN  AN  ILLEGAL  ANSWER* “y 
&/y  "GIOE  HER  ANOTHER  SHOT  ~>  _") 

C 

2000  FORMAT  CENTER  THE  APPROPRI A TE ‘ y 5X y 

S44  ( "X"  ) y/y  "NUMDERy  OR  ZERO  "ID  QUIT  ~>  _ " ) 


X 


II 


X"  ) 
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0279 

0280 
0281 
0282 

0283 

0284 

0285 

0286 

0287 

0288 

0289 

0290 

0291 

0292 

0293 

0294 

0295 

0296 

0297 

0298 

0299 

0300 

0301 

0302 

0303 

0304 

0305 

0306 

0307 

0308 

0309 

0310 

0311 


C 

1010  FORMAT  < 17X*  INPUT  RE  SP0NSES/6R0U?a‘i  WATER  HYDROLOGY  V/ ) 

C 

2010  FORMAT  < 17X*EDIT  RESP0NSES/6R0UND  WATER  HYDROLOGY*//) 

C 

3010  FORMAT  ( l/X-EDIT  EXPECTATIONS/GROUND  WATER  HYDROLOGY*//) 

C 

2020  FORMAT  < 5X‘1N  WHICH  HEADING  IS  YOUR  DESIRED  EDIT?*/? 

&5X*  (ENTER  A?BtC?D?E?OR  NONE)  ->  _ * ) 

C 

2030  FORMAT  <A2) 

C 

2040  FORMAT  ( 5X*Y0UR  CURRENT  RESPONSE  IS  ->*I2?//? 

&5X* ENTER  YOUR  NEW  RESPONSE  HERE  ->  „*) 

C 

3020  FORMAT  < 5X*IN  WHICH  SUB-HEADING  IS  THE  EXPECTATION  MALUE*/? 
&5X"Y0U  WISH  TO  CHANGE  ? (ENTER  THE  APPROPRIATE  NUMBER)  ->  _ * ) 
C 

3030  FORMAT (/5X* SELECT  THE  LAND  USE  OPTION  YOU  WISH  TO  CHANGE*/ 

> IX*  -1-  / -2-  / -3-  / -4-  / -5-  / -6-  /“/ 

> 1X"CR0PLAND/NAT ♦UEG*/WILDLIFE/WAT*REC«/HIGH  USE/  OTHER/* 

>/5X* ENTER  YOUR  SELECTION  HERE  ->  „ * ) 

C 

3040  FORMAT  ( 5X*ENTER  YOUR  NEW  EXPECTATION  MALUE  HERE  ->  „*) 

C 

3050  FORMAT  (/?  5X*ERR0R — > YOUR  EXPECTATION  VALUE  MUST  BE*/? 
%5X*0?1?2?3?  OR  4 TO  AVOID  INTRODUCING  A BIAS  ->  _*) 

C 

3060  FORMAT  ( 5X*ANY  MORE  EDITS  TO  GROUND  WATER  HYDROLOGY?*/? 

S5X*  (YES  OR  NO)  ->  .- * ) 

C 

END 

END$ 
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&IEV 

0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 

0011 

0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 

0021 

0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

004  7 

0048 

0049 

0050 

0051 

0052 

0053 

0054 


T=00004  IS  ON  CR00015  USING  00013  BLKS  R=0000 


FTN4 

SUBROUTINE  JEMS  ( ICN y IHN y lEX ) 

C INPUT  EXPECTATION  OALUES 

C 
C 

C LEUEL  2 
C 

C lEOS  READS  THE  USER-INPUT y NON-STANDARD  EXPECTATION  OALUES 

C FOR  THE  CURRENT  CATEGORY  HEADING* 

C 

C THE  CALLING  SEQUENCE  IS  : 

C 

C CALL  lEVS  (ICNylHNylEX) 

C 

C WHERE  I 
C 

C ICN  ->  CATEGORY  NUNBER 

C IHN  ->  CATEGORY  HEADING  NUMBER 

C lEX  ->  EXIT  CELL  : SET  TO  -1  FOR  RETURN 

C 

C THE  LOCAL  VARIABLES  ARE  t 
C 

C MEV  -> 

C I ADD  -> 

C ITNS  ~> 

C ISWl  -> 

C 

C ISW2  -> 

C 

C ISW3  -> 

C 
C 

C THIS  ROUTINE 
C 

C CLAIM  RELEASE  1*0  - APRIL  ly  1980 

C 

COMMON  ICOM  (6176) 

C 

EQUIVALENCE  (ICOM  (46) y LUT) 

EQUIVALENCE  (ICOM  (114) y LUO) 

C 

INTEGER  ISWl  (10) y ISW2  (10)y  ISW3  (10) 

C 

DATA  ISWl  73859 y 381 ly 4681. 4363 y 4021 y 
4543y 3907 y 4879 y 3733 y 4189/ 

C 

DATA  ISW2  765y63y 102y88y74y96y68yllly60y82/ 

C 

DATA  ISW3  /118yll7y 125y 123yl20y 124y 119yl27y 116y 122/ 

c 

MEV  =•-•  4 
lEX  ==  0 
I ADD  = 0 


MAXIMUM  EXPECTATION  VALUE 
ADDITION  10  STARTING  WORD  IN  ICOM  ARRAY 
TOTAL  NUMBER  OF  SUBHEADINGS  IN  CATEGORY 
ARRAY  CONTAINING  STARTING  WORD  OF  EXPECTATION 
ARRAY  IN  ICOM 

ARRAY  CONTAINING  STARTING  WORD  OF  NUMBER  OF 
SUBHEADINGS/HEADING  ARRAYS  IN  ICOM 
ARRAY  CONTAINING  STARTING  WORD  OF  NUMBER 
OF  HEADINGS  POINTERS  IN  ICOM 

WAS  WRITTEN  BY  GREEN 
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0055 

0056 

0057 

0058 

0059 

0060 

0061 

0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 


ITMS  = 0 

C DETERMINE  TOTAL  NUMBER  OF  SUBHEADINGS  IN  CATEGORY 
DO  3 I ly  ICOM  <ISU3  (ICN)) 

C DETERMINE  INCREMENT  TO  ADD  TO  STARTING  UORD 
3 ITNS  - ITNS  + ICOM  (ISW2  (ICN)  +1-1) 

IF  (IHN  ♦EQ.  1)  GOTO  10 
DO  5 I = It  IHN  - 1 

5 lADD  = lADD  + ICOM  (ISW2  (ICN)  +1-1) 

C INPUT  THE  EXPECTATION  UALUE 

10  DO  20  I 1»  ICOM  (ISW2  (ICN)  + IHN  - 1) 

WRITE  (LUT,  1000)  I 
15  READ  (LUT?  lEX 

C TEST  lEX  OALUE  FOR  VALIDITY  (-1  MEANS  EXIT) 

IF  (lEX  »EtK  -1)  RETURN 

IF  (lEX  *GE*  0 *AND^  lEX  *LE»  MEM)  GOTO  20 
WRITE  (LUlf  1001) 

GOTO  15 

C PUT  I EX  OALUE  IN  COMMON  BLOCK  AND  QUIT 

20  ICOM  (ISWl  (ICN)  + (LUO  - 1 ) *:  ITNS  + lADD  +!-!)  = lEX 
RETURN 

1000  FORMAT  ( IX " SUBHEADING  “12‘'  EXPECTATION  VALUE  (-1  TO  QUIT)->  _ '*  ) 

1001  FORMAT  (IX “ERROR.  EXPECTATION  VALUE  OUT  OF  BOUNDS.  RE-INPUT  ->  _“) 
END 

END+ 
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SISNEV  1=^:00004  IS  ON  CROOOIS  USING  00056  BLKS  R-0000 


0001  FTN4 

0002 
0003  C 


SUBROUTINE  ISNEO 

INPUT  STORE  NON-STANDARD  EXPECTATION  VALUES — 


0004  C 

0005  C LEVEL  1 

0006  C 

0007  C ISNEV  IS  ACCESSED  BY  CLAIM  TO  ALLOW  USER-DESCRIBED? 

0008  C NON-STANDARD  EXPECTATION  OF  SUCCESS  VALUES  TO  BE  : 

0009  C INPUT  MANUALLY  BY  THE  USER  (IPNTR  1) 

0010  C STORED  IN  A USER-NAMED  FILE  (IPNTR  = 2) 

0011  C tt  READ  FROM  A USER-NAMED  FILE  (IPNTR  = 3) 

0012  C 

0013  C ALL  FILES  CONTAIN  THE  CHARACTERS  IN  THE  FIRST  WORD  OF  THE  ID 

0014  C SEGMENT 

0015  C 

0016  C THE  CALLING  SEQUENCE  IS?  CALL  ISNEV 

0017  C 

0018  C ISNEV  CALLS  SUBROUTINE  lEVS  TO  INPUT  AN  EXPECTATION  VALUE 

0019  C 

0020  C ISNEV  USES  THE  TCS  ROUTINES:  ERASE  AND  HOME?  AND 

0021  C CALLS  THE  SYSTEM  ROUTINE  I SPOLU. 


0022  C 

0023  C 

0024  C 

0025  C 

0026  C 

0027  C 

0028  C 

0029  C 

0030  C 

0031  C 

0032  C 

0033  C 

0034  C 

0035  C 

0036  C 

0037  C 

0038  C 

0039  C 

0040  C 

0041  C 

0042  C 

0043 


CLAIM  RELEASE  1.0?  APRIL  1?  1980 


THE  LOCAL  VARIABLES  ARE 


THIS  ROUTINE  WAS  WRITTEN  BY  GREEN 


ISNEV  DECLARES  LABEL  COMMON  ALTRN  AND  CTIL 


FILID  - ID  SEGMENT  FOR  EXPECTATION  FILE  (INTEGER) 

IANS  - ANSWER  CELL 

ICN  - CATEGORY  NUMBER 

lEX  - EXIT  CELL 

IHEAD  - HEADING  LETTER  ARRAY 

IHL  - HEADING  LETTER 

IHN  - HEADING  NUMBER 

IPTR  - LOCAL  POINTER 


COMMON  ITEK  (45) 


TEKTRONIX  COMMON 


0044  C 

0045  C 

0046  C 

0047 


LOGICAL  UNITS  AND  COMMON  LOCATION 


COMMON  IARRY(5) ? 1ARY2(5) ?LER?LUF?LUL 


0048  C 

0049  C 

0050  C 

0051 


POINTERS 
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0055 

0056 

0057  C 

0058  C 

0059  C 

0060 
0061 
0062 

0063  C 

0064  C 

0065  C 

0066 

0067 

0068 

0069  C 

0070  C 

0071  C 

0072 

0073 

0074 

0075  C 

0076  C 

0077  C 

0078 

0079 

0080 

0081  C 

0082  C 

0083  C 

0084 

0085 

0086 

0087 

0088 

0089 

0090  C 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099  C 

0100 
0101 
0102 

0103 

0104 

0105 

0106 

0107  C 

0108 

0109  C 

0110 


COMMON  NOOR  yNSECTS  >NSOC  » NSU8  ^NSUR 

COMMON  NTOP  jNU  >N0EG 

GRADING  PARAMETERS 

COMMON  AREA (5) y BENLEN ( 5 y 10 ) >BENWI (5^ 10) > COGO > 6CPA ( 5 ) 
COMMON  6RD0BS(5) t HOHT ( 5 j 10 ) ? HWSL I ( 5 » 1 0 ) » NBPP ( 5 ) y PCEQl 9 ( 4 ) 
COMMON  PERCNT  < 5 y 1 0 ) y REHCP Y < 5 ) y REHMOL  < 5 ) y SLOPE ( 5 y 1 0 ) y WBP 


CATEGORY  TEXT 


COMMON  ANI M ( 23  y 1 3 ) y CLMA ( 1 3 y 1 3 ) y ODES ( 1 5 y 1 3 > y GWHY ( 22  y 1 3 ) 
COMMON  00BD(llyl3) ySBSL<13) y SCEC ( 33 y 13 ) y SUMY ( 44 y 1 3 ) 
COMMON  TPSL ( 49  y 1 3 ) y 06T A ( 1 5 y 1 3 ) 


EXPECTATION  VALUES 

COMMON  ANIMAL(13y6) y CL IMAT < 8 y 6 ) y GENDES ( 8 y 6 ) y GRUH YD ( 1 9 y 6 ) 
COMMON  0VRBDN(28y6) y SOCECN ( 29 y 6 ) y SUBSOI ( 30 y 6 ) y SURHYD < 23 y 6 ) 
COMMON  T0PS0I(33y 6) y VEGETA < 10 y 6 ) 


CATEGORY  RESPONSES 

COMMON  RANIMA<3) y RCLIMA ( 2 ) y RGENDE < 3 ) y R6RWHY ( 5 ) 
COMMON  R0VRBD<7y 10) y RS0CEC(6) yRSUBS0(8) yRSURHY<6) 
COMMON  RT0PS0(9) yRVEGET<2) 

EEASIyTECONyOPUSE  SUBSYSTEM  PARAMETERS 

COMMON  CAAHMyCABAHyCABFN<3) y CABFP ( 3 ) y CABHM 

COMMON  CABS ( 2 ) y CAC  y CACP  y CADF  y CADH 

COMMON  CADS  y CAEAF  y CAHSAF  y CAHSTS  y CAIP 

COMMON  CAR3FCyCASF  yCASNCyCSTESyCSTRM 

COMMON  CSTRP  y F AV6 ( 5 ) y PFSTSP  y PFAC  y RCLTEC  < 29  y 34 ) 

COMMON  TCAR(5)  yTHICKdO)  yTHKTSyTTL(40) 


INTEGER 

INTEGER 

INTEGER 

INTEGER- 

INTEGER 

INTEGER 

INTEGER 

INTEGER 


EXI T y CLMA  y GDES  y 6WH Y y OVBD  y SBSL 
SCEC  y SUHY  y TPSL  y VGT A y ANIM 
CLIMAT  y 6ENDES  y GRWH YD  y OVRBDN 
SOCECN  y SUBSOI y SURHYD  y TOPSOI 
VEGETA y ANIMAL 

RCLIMA  y RGENDE  y R6RWH Y y ROVRBD  y RSOCEC 
RSUBSO  y RSURHY  y RTOPSO  y RVEGET  y RANI MA 
RCLTEC yTTL 


INTEGER  COMMON  (1) 

EQUIVALENCE  (COMMON  (l)y  ITEK  (1)) 
EQUIVALENCE  (lARRY  (l)y  LUT) 
EQUIVALENCE  (IARY2  (l)y  ISTRK) 
EQUIVALENCE  (IARY2  (2)y  ISECT) 
EQUIVALENCE  (IARY2  (3)y  ICODE) 
EQUIVALENCE  (1ARY2  (4)y  LEN) 

LOGICAL  LER 

COMMON  /ALTRN/  ALTN 
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0111 

0112 

oii:-i 

0114 

0115 

0116 

0117 

0118 

0119 

0120 
0121 
0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 
0161 
0162 

0163 

0164 

0165 

0166 


COMMON  /CTIL/  ICAT 

INTEGER  ALTN  (6?4)y  ICAT  (103-12)y  IHEAD  (9)^  EILID  (3) 

DATA  IHEAD  /2HA  y2HD  ?2HC  »2HD  ?2HE  y2HF  »2HG  t2HH  y2HI  / 
DATA  ICR/ 15/ 

C 

C SET  FIRST  WORD  OF  ID  SEGMENT 

FILID  (1)  = 2H#$ 

IF  (IPNTR  ♦EQ*  1)  100?  500 

C USER  INPUT  OF  NON-STANDARD  EXPECTATION  VALUES 

C GET  THE  CATEGORY 

100  IPTR  = 1 

IF  <LER)  CALL  ERASE 
IF  (LER)  CALL  HOME- 
WRITE  (LU'I?  1000) 

105  READ  (LUT?  t)  ICN 

IF  (ICN  *EQ*  -1)  110?  115 

C ICN  = -1  =>  INPU'T  THE  'OTHER'  ALTERNATIVE 

C BET  IPTR  TO  2 AND  LUO  TO  6 

110  IPTR  ==  2 
LUO  = 6 
GOTO  200 

C TEST  ICN  FOR  VALIDITY  ZERO  MEANS  QUIT 

115  IF  (ICN  *EQ*  0)  RETURN 

IF  (ICN  .GE\  1 iAND<  ICN  .LE.  NSECTS)  GOTO  120 
WRITE  (LU'r?  1001) 

GOTO  105 

C GET  THE  CATEGORY  HEADING 

120  WRITE  (LUT?  1002) 

125  READ  (LUT?  1003)  IHL 
IHN  = 0 

DO  126  K ==  1?9 

IF  (IHL  ♦EQ.  IHEAD 

126  CONTINUE 

IF  (IHL  .EQ.  2HN0) 

IF  (IHN  .EQc  0) 

C GET  THE  LAND 

130  WRITE  (LUT?  1004) 

DO  135  I = 1?  6 
135  WRITE  (LUT?  1005)  I? 

WRITE  (LUT?  1006) 

140  READ  (LUT?  t)  LUO 

IF  (LUO  <EQ<  0)  GOTO  120 

IF  (LUO  *GE*  1 ^AND«  LUO  <LE.  6)  GOTO  160 
WRITE  (LUT?  1001) 

GOTO  140 

C ERROR  ->•  INVALID  HEADING  NUMBER 

150  WRITE  (LUT?  1011) 

GOTO  120 

C SHOW  USER  CURRENT  STATUS 

160  IF  (LER)  CALL  ERASE 
IF  (LER)  CALL  HOME 

WRITE  (LUT?  1007)  (ICAT  (ICN?  J)?  J = 1?  12)? 

> IHEAD  (IHN)?  (ALTN  (LUO?  K)?  K = 1?  4) 

GOTO  (210?  230?  250?  270?  290?  330?  330?  350?  370?  390)  ICN 
C GENERAL  DESCRIPTION  CATEGORY 

200  ICN  ICN  -f  2 


(K))  IHN  = K 

GOTO  100 
GOTO  150 

USE  OPTION  REFERENCE  NUMBER 


(ALTN  (I?  J) ? J = 1?  4) 
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0167 

IHN  = 

0 

0168 

205 

IHN  = 

IHN  -f  1 

0169 

IF 

(IHN  ♦LE*  NGEN)  GOTO  160 

0170 

210 

IF 

(IHN  «GT«  NGEM)  GOTO  (150» 

220) 

IP 

0171 

CALL 

lEMS  (ICN»IHN,1EX) 

0172 

IF 

(lEX  *EQ*  -1)  GOTO  100 

0173 

IF 

(IPTR  *EQ.  1)  -130»  205 

0174 

C 

CLIHATOLOGY  CATEGORY 

0175 

220 

ICN  = 

ICN  T 1 

0176 

IHN  = 

0 

0177 

w 

IHN  = 

IHN  -f  1 

0178 

IF 

(IHN  *LE»  NCLI)  GOTO  160 

0179 

230 

IF 

(IHN  «GT.  NCLI)  GOTO  (150> 

240) 

IP 

0180 

CALL 

lEOS  (ICNylHNylEX) 

0181 

IF 

(lEX  ♦EQ*  -1)  GOTO  100 

0182 

IF 

(IPTR  *EQ.  1)  130>  225 

0183 

C 

TOPSOIL  CATEGORY 

0184 

240 

ICN  = 

ICN  -f  1 

0185 

IHN  = 

0 

0186 

245 

IHN  = 

IHN  + 1 

0187 

IF 

(IHN  «LE»  NTOP)  GOTO  160 

0188 

250 

IF 

(IHN  <GT.  NTOP)  GOTO  (150? 

260) 

IP 

0189 

CALL 

lEOS  (ICN?IHN?IEX) 

0190 

IF 

(lEX  *EQ*  -1)  GOTO  100 

0191 

IF 

(IPTR  .ECU  1)  130?  245 

0192 

C 

SUBSOIL  CATEGORY 

0193 

260 

ICN 

ICN  i 1 

0194 

IHN  = 

0 

0195 

265 

IHN  = 

IHN  + 1 

0196 

IF 

(IHN  *LE.  NSUB)  GOTO  160 

0197 

270 

IF 

(IHN  tGT.  NSUB)  GOTO  (150? 

280) 

IP 

0198 

CALL 

lEVS  (ICN?IHN?IEX) 

0199 

IF 

(lEX  .ECU  -1)  GOTO  100 

0200 

IF 

(IPTR  .ECU  1)  130?  265 

0201 

C 

OVERBURDEN  CATEGORY 

0202 

280 

ICN  = 

ICN  -f-  1 

0203 

IHN  = 

0 

0204 

285 

IHN  = 

IHN  + 1 

0205 

IF 

(IHN  .LE*  NOUR)  GOTO  160 

0206 

290 

IF 

(IHN  <GT.  NOVR)  GOTO  (150? 

300) 

IP 

0207 

CALL 

lEVS  (ICN?1HN?IEX) 

0208 

IF 

(lEX  .ECU  -1)  GOTO  100 

0209 

IF 

(IPTR  .EQ.  1)  130?  285 

0210 

C 

SURFACE  WATER  HYDROLOGY 

CATEGORY 

0211 

300 

ICN  = 

ICN  T 1 

0212 

IHN  = 

0 

0213 

305 

IHN  = 

IHN  + 1 

0214 

IF 

(IHN  .LE.  NSUR)  GOTO  160 

0215 

310 

IF 

(IHN  .GT.  NSUR)  GOTO  (150? 

320) 

IP 

0216 

CALL 

lEVS  (ICN?IHN?IEX) 

0217 

IF 

(lEX  <ECU.  -1)  GOTO  100 

0218 

IF 

(IPTR  .EQ.  1)  130?  305 

0219 

C 

GROUND  WATER  HYDROLOGY 

0220 

320 

ICN  = 

ICN  + 1 

0221 

IHN  = 

0 

0222 

325 

IHN  = 

IHN  T 1 

199 


0223 


IF  (IHN  *LE*  N6RW)  GOTO  160 


0224 

022G 

0226 

0227 

0228 

0229 

0230 

0231 

0232 

0233 

0234 

0235 

0236 

0237 

0238 

0239 

0240 

0241 

0242 

0243 


330  IF  (IHN  ♦GI^  NGRk«)  GOTO  <150>  340)  IPTR 
CALL  ILL'S  (ICNylNN^IEX) 

IF  <IEX  ♦LQ.  --1)  GOTO  100 
IF  (IPTR  1)  130 y 325 

C VEGETATION 

340  ICN  ==  ICN  + 1 
IHN  ==  0 

345  IHN  = IHN  + 1 

IF  (IHN  ♦LE*  NVEG)  GOTO  160 
350  IF  (IHN  *GT*  NVEG)  GOTO  (150>  360)  IPTR 
CALL  lEVS  (ICNjIHNjIEX) 

IF  (lEX  <EQ.  -1)  GOTO  100 
IF  (IPTR  *EQ.  1)  130>  345 

C ANIMALS  CATEGORY 


360 

ICN  = 

ICN 

T- 

1 

IHN  = 

0 

365 

IHN  = 

IHN 

+ 

1 

IF  (IHN  ♦LE«  NANM)  GOTO  160 
370  IF  (IHN  ^GT*  NANM)  GOTO  (150?  380)  IPTR 
CALL  IE VS  (ICN? IHN? 1 EX) 


0244 

0245 

0246 

0247 

0248 

0249 

0250 

0251 

0252 

0253 

0254 

0255 

0256 

0257 

0258 

0259 

0260 
0261 
0262 

0263 

0264 

0265 

0266 

0267 

0268 

0269 

0270 

0271 

0272 

0273 

0274 

0275 

0276 
027'  7 
0278 


C 

380 

385 

390 


C 

C 

500 


C 


C 

C 

C 

C 


505 


IF  (lEX  <ECU  -1)  GOTO  100 
IF  (IPTR  ♦ECK  1)  130?  365 

SOCIO-ECONOMICS  CATEGORY 
ICN  = ICN  T 1 
IHN  =•■  0 
IHN  IHN  + 1 

IF  (IHN  ♦LE*  NSOC)  GOTO  160 
IF  (IHN  ^GT*  NSOC)  GOTO  (150?  100)  IPTR 
CALL  lEVS  (1CN?IHN?IEX) 

IF  (lEX  ♦EQ»  -1)  GOTO  100 
IF  (IPTR  «EQ.  1)  130?  385 

STORE  EXPECTATION  VALUES  CURRENTLY?  EXPECTATION 
VALUES  USE  UORDS  3733  - 4938  OF  THE  CLAIM  COMMON  BLOCK 
IF  (LER)  CALL  ERASE 
IF  (LER)  CALL  HOME 
IFdPNTR  *EQ*  2)  WRITE  ( LUT  ? 1012 ) 

IFdPNTR  .EQ»  3)  WRI TE ( LUT ? 1013 ) 

WRITE  (LUT?  1008) 

READ  (LUT?  1009)  (FILID  (J)?J  = 2?3) 

DOES  THE  FILE  EXIST  ? 

CALL  SPOLU  (LUF?FILID?2? 1 ? ICR) 

IF  (LUF  .EQ*  -6)  GOTO  (511?  520)  IPNTR  - 1 
IF  (LUF  »LT.  0)  STOP  1 

THE  FILE  HAS  BEEN  SUCCESSFULLY  OPENED*  IF  THE 
USER  IS  STORING  DATA?  MAKE  SURE  THAT  HE  WANTS 
TO  PURGE  THE  EXISTING  FILE*  IF  THE  USER  IS 
RETRIEVING  DATA?  WE"RE  OK* 

READ  (LUF?  1014)  TTL 

IF  (IPNTR  *EQ*  3)  GOTO  550 
WRITE  (LUT?  1015)  (FILID  (J)?  J=2?3)  ? TTL 
READ  (LUT?  1003)  IANS 

IF  (IANS  *EQ*  2HYE)  GOTO  510 

IF  (IANS  *E0*  2HN0)  GOTO  515 

WRITE  (LUT?  1017)  IANS 

GOTO  505 
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c 


c 

c 


c 

c 


c 

c 

c 


c 


0279 

0280 
0281 
0282 

0283 

0284 

0285 

0286 

0287 

0288 

0289 

0290 

0291 

0292 

0293 

0294 

0295 

0296 

0297 

0298 

0299 

0300 

0301 

0302 

0303 

0304 

0305 

0306 

0307 

0308 

0309  C 

0310 

0311 

0312 

0313 

0314 

0315 

0316 

0317 

0318 

0319 

0320 

0321 

0322 

0323 

0324 

0325 

0326 

0327 

0328 

0329 

0330 

0331 

0332 

0333 

0334 


510 


511 


c:  ^ cr 


516 

517 


530 


535 


C 


C 


C 


CALL  SPOLU 
IF  (LUF 


CALL  SPOLU 
IF  (LUF 
GOTO  530 


CALL  SPOLU 
IF  (LUF 


PURGE  THE  EXISTING  FILE. 
(LUF  >FILIDy2»3y ICR) 

♦LT*  0)  STOP  2 

OPEN  THE  FILE  IN  THE  WRITE 


AND  BRANCH  TO  DATA 
(LUF,FILIDj 3y 1 ? ICR) 
♦LT.  0)  STOP  3 


STORAGE 


MODEy 

CODE. 


CLOSE 


TO 


THE  FILE. 
INPUT  A NEW 


IF 

FILE 


THE  USER  WANTS 
NAHEy  START  GOER 


t 


OTHERWI 


oc*  _ 

u->  i_  9 


RETURN 


WRITE 

READ 

IF 

IF 

WRITE 


(LUTy 

(LUTy 

(IANS 

(IANS 

(LUTy 


(LUFyFILIDy2y2y ICR) 
.LT.  0)  STOP  4 
1018) 

1003)  IANS 
.EQ.  2HYE) 

.EG.  2HN0) 

1017)  IANS 


GOTO  500 
RETURN 


GOTO  517 


20  WRITE  (LUTy 


GOTO 


51 


WRITE 
READ 
WRITE 
DO  535 
WRITE 


(LUTy 
(LUTy 
(LUFy 
I = 
(LUFy 


USER  IS  RETRIEVING  AND  THE  FILE 
GIVE  MESSAGE y AND  ALLOW  THE  USER 
THE  FILE  NAME. 

1019)  (FILID  (J)y  J=2y3) 

STORE  THE  VALUES 

1020) 

1014)  TTL 
1014)  TTL 
3733y  4938  y 6 

1010)  (COMMON  (J)y  J = ly  1+5) 


IS 


NON-EXISTENT. 
TO  RE- INPUT 


CLOSE  FILID  AND  RETURN 


(LUFyFILIDy3y2ylCR) 
.LT.  0)  STOP 


5 


•=^50 


560 


CALL  SPOLU 
IF  (LUF 
RETURN 

RETRIEVING 

WRITE  (LUTy  1021)  (FILID 
DO  560  I = 3733y  4938 y 6 
READ  (LUFy  1010)  (COMMON  (J)y  J = 
READ  SUCCESSFUL  CLOSE 
CALL  SPOLU  (LUFyFILIDy2y2y ICR) 
IF(LER)  CALL  TINPT(IANS) 

IF(LER)  CALL  BELL 
RETURN 


(J)y  J=2y3)y  TTL 


ly  1 ■ 

FILID 


5) 


AND  RETURN 


1000 


FORMAT 
5X*  -1 
5X* 

0 
1 


5X  ■ 
5X* 
5X‘ 
5X" 
5X" 


;x 


5X" 

5X“ 

5X* 


FORMAT  STATEMENTS 

NON-STANDARD  EXPECTATION  VALUES 
->  INPUT  OTHER  OPTION  FOR  ALL  CATEGORIES*/ 
(STARTING  WITH  CATEGORY  1)"/ 

->  EXIT  FROM  THIS  ROUTINE‘/y 

->  GENERAL  DESCRIPTION  CATEGORY*/y 

->  CLIMATOLOGY  CATEGORY */y 

->  TOPSOIL  CATEGORY*/y 

->  SUBSOIL  CATEGORY'/y 

->  OVERBURDEN  CATEGORY */y 

->  SURFACE  WATER  HYDROLOGY  CATEGORY */y 

->  GROUND  WATER  HYDROLOGY  CATEGORY */y 

->  VEGETATION  CATEGORY */y 
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0335  > 5X'  9 ->  ANIHALS  CATEGORY Vt 

0336  > 5X*  10  ~>  SOCIO-ECONOMICS  CATEGORY */y 

0337  > 5X*  INPUT  —>  „“) 

0338  C 

0339  1001  F-ORMAT  < 5X ' >KXcERROR)f'«  ILLEGAL  ENTRY*  RE-INPUT  -> 

0340  C 

0341  1002  F"ORMAT  (SX'INPUT  Tf^E  HEADING  - LETTER  (NONE  TO  EXIT)  ->  „*) 

0342  C 

0343  1003  FORMAT  (A2) 

0344  C 

0345  1004  FORMAT  <5X"LAND  USE  OPTION  :*) 

0346  C 

0347  1005  FORMAT  (5XrI2‘  ->  MA2) 

0348  C 

0349  1006  FORMAT  (5X* INPUT  REFERENCE  NUMBER  (0  TO  EXIT)  ->  _‘) 


0350 

0351 

0352 

0353 

0354 

0355 

0356 

0357 

0358 

0359 

0360 

0361 

0362 

0363 

0364 

0365 

0366 

0367 

0368 

0369 

0370 

0371 

0372 

0373 

0374 

0375 

0376 

0377 

0378 

0379 

0380 

0381 

0382 

0383 

0384 


C 

1007  FORMAT  (5X*  CURRENT  CATEGORY  IS  ->  •12A2>/ 

> 5X"  CURRENT  HEADING  IS  ~>  "A2j/y 

> 5X'  CURRENT  LAND  USE  OPTION  IS  ->MA2y/ 

> 5X"  

C 

1008  F0RMAT(//y5X‘ INPUT  THE  FILE  NAME  ->  _') 

1009  FORMAT  (2A2) 


C 

1010  FORMAT  (611) 

C 

1011  F0RMAT(/y5X*ERR0R:^:){c  ILLEGAL  HEADING  LETTER  SPECIFIED.* 


C 

1012  FORMAT  (5X*DATA  STORAGE*/ 

5X “ NON-STANDARD  EXPECT AT I ON  MALUES “ / 

> 5X“ “///) 

1013  FORMAT  (5X*DATA  RETRIEVAL*/ 

> 5X* NON-STANDARD  EXPECTATION  VALUES*/ 

> 5X* *///) 

1014  FORMAT  (40A2) 

1015  FORMAT  (5Xy*THE  FILE  '*2A2*"  ALREADY  EXISTS. *// 

> 5Xy*THE  TITLE  IS  t * y / y 5X y 40A2 y // y 

> 5Xy*D0  YOU  WANT  TO  WRITE  OVER  THIS  FILE  ?*/ 


5Xy  * (YES 


1017 

1018 

1019 

1020 


OR  NO)  • 
(lXyA2y •?? 


(5X.y*D0  YOU  WANT  TO  RE-ENTER  THE  FILE  NAME 


FORMAT 
FORMAT 

5Xy*ENlER  YES  OR  NO 
FORMAT  (5Xy*THE  FILE  "'2A2*' 


<ERROR>  RE-ENTER  YOUR  RESPONSE 


•>  _*) 
DOES  NOT 


EXIST. •//) 


5X 


*FILE~>_* ) 

1021  F0RMAT(//y5X*RETRIEVING  DATA  FROM 


*2A2y /y 


? * / 


F0RMAT(5Xy *INPUT  THE  TITLE  ASSOCIATED  WITH  THIS*/ 


>5X* TITLE”/  *40A2y 

>//ylXy*HIT  THE  RETURN  KEY  TO  CONI INUE . . ♦ _ * ) 
END 

END$ 


) 


) 


/) 
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SHNMXF  1=00004  IS  ON  CR00015  USING  00012  BLKS  F<=0063 


0001 

0002 

0003 

0004 
OOOG 
0006 

0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 

0053 

0054 


FTN4 

SUBROUTINE  HNMXF  ( LUT  y MODE  y KCUT  y 6RD0BS  y TSMAX  y TSMI N y KCODE ) 

C MINIMUM  AND  MAXIMUM  FINAL  SLOPE  VALUES  

C 

C LEVEL  5 
C 

C SUBROUTINE  MNMXF  IS  ACCESSED  BY  BUILD  AND  DLISP  TO  RETURN 
C THE  MAXIMUM  AND  MINIMUM  FINAL  SLOPE  VALUES 
C 

C THE  CALLING  SEQUENCE  IS  t 
C 

C CALL  MNMXF  < LUI y MODE y KCUT y 6RDVBS y TSMAX y TSMI N y KCODE ) 

C 

C WHERE 
C 

C LUT  IS  THE  LOGICAL  UNIT  OF  THE  USER"S  TERMINAL 

C MODE  IS  THE  MODE  INDICATOR  (AS  DEFINED  IN  CLAIM  COMMON) 

C KCUT  IS  THE  CUT  OPTION  (AS  DEFINED  BY  RGENDE(2)  IN  CLAIM  COMMON) 

C GRDVBS  IS  THE  GRADING  VARIABLES  ARRAY  (AS  DEhlNED  BY  CLAIM  COMMON) 

C TSMAX  IS  THE  MAXIMUM  FINAL  SLOPE  VALUE 

C TSMIN  IS  THE  MINIMUM  FINAL  SLOPE  VALUE 

C KCODE  IS  A SWITCH  WHERE J 

C 1 ~>  READ  TSMAX  y TSMIN  FROM  USER 

C 2 ->  RETURN  TSMAX y TSMIN  DIRECTLY 

C 3 ->  MIN  AND  MAX  ARE  EQUAL 

C 

C THIS  ROUTINE  WAS  WRITTEN  BY  GREEN 
C 

C CLAIM  RELEASE  1 . 0 - APRIL  ly  1980 

C 

DIMENSION  GRDVBS(5) 

C 

C DETERMINE  MINIMUM  PERMISSABLE  FINAL  SILOPE  VALUE 

TSMIN  = AMAXKll*  y6RDVBS(4)  ) 

IF(KCUT*EQ,2)  TSMIN  = GRDVBS(4) 

IF(KCUT*EQ* 1 ♦AND*M0DE*EQ*4)  TSMIN  = GRDVBS(4) 
IF(KCUT»EQ*3.AND.M0DE*EQ.4)  TSMIN  = 0*1 
IF(KCUT*EQ*3»AND*M0DE»NE*4)  TSMIN  = 11 ♦ 

C DETERMINE  MAXIMUM  PERMISSABLE  FINAL  SLOPE  VALUE 

IF(M0DE»EQ»4)  10y20 
10  TSMAX  = GRDVBS (2) 

IF(KCUT»EQ*3)  TSMAX  = AMINl ( GRDVBS ( 4 ) y GRDVBS ( 5 ) ) 

C MAKE  SURE  THAT  THE  FINAL  MINIMUM  SLOPE  VALUE  FOR 

C 'the  final  CUT  OPTION  IS  LEGAL 

IF ( KCUT . EQ . 3 . AND . TSMIN . GT  « TSMAX ) TSMI N=T SMAX 
GOTO  30 

20  TSMAX  = AMINl ( 19 ♦ y GRDVBS (2) ) 

1F(KCUT*EQ*3)  TSMAX  = AMINl ( 19 . y GRDVBS ( 4 ) y GRDVBS ( 5 ) ) 

C READ  THE  USER'S  REQUESTED  LIMITS  (OR  RETURN) 

30  IF ( TSMIN tEQ* TSMAX)  GOTO  35 

IF(KC0DE*EQ*2)  RETURN 
WRITE(LUTy 1000)  TSMINy  TSMAX 
R E A D a.  U T y ) T S M I N 1 y T S hi  A X 1 
C TEST  ALL  POSSIBILITIES 
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0055 

0056 

0057 

0058 

0059 

0060 
0061 
0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 


C 

C 


IF( 

• TSMINl 

• TSMINl 

• TSMINl 

• ISM AX 1 
ISM IN  = 
TBMAX  = 
RE) URN 


35  KC0DE==3 


LT.TSMIN 

6E*TSMAXi 

GEMSMAX 

GT*TSMAX 

TSMINl 

TSMAXl 


.OR* 

♦ OR. 

♦ DR  ♦ 

GOTO  30 


MAXIMUM  AND  MINIMUM  SLOPES  ARE  THE  SAME. 
AND  TELL  USER 


SET  KCODE 


URITE(LUTy36) 

RETURN 

C FORMAT  STATEMENTS 

1000  F0RMAT(//5X*THE  LOWER  AND  UPPER  FINAL  SLOPE  LIMITS  ARE  :V 

> 5X'  — LOWER  =-*'F5.1"  DEGREES  “ 

>/  5X*  — UPPER  =“F5.1*  DEGREES"// 

5X"INPUT  THE  LOWER  LIMIT?  FOLLOWED  BY  A COMMA?"/ 

> 5X"THEN  THE  UPPER  LIMIT  THAT  YOU  WISH  TO  OIEW  •“>  _") 


C 


36 


FORMAT (//5X" THE  LOWER  AND  UPPER  FINAL  SLOPE  LIMITS  ARE" 
• / 5X"EQUAL.  NO  GRAPHS  OR  TABLES  ARE  AVAILABLE") 

END 


END$ 
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gOF'USE  T=:0000^,  IS  ON  CR00015  USING  00024  BLKS  R-OOOO 


0001  FTN4 


0002 

0003 

C 

c 

=: == SUBROUTINE 

OPUSE  — =:• 

0004 

c 

OPT  I HUN  USE  FACTORS 

0005 

c 

=: 

rr 

0006 

c 

= SOURCE  FILE  t &OPUSE 

OBJECT  FILE  : %OPUSE  = 

0007 

c 

z::  z::  ::z:  zn  z::  zr.  zz  zz  zr. ::::  :z:  zz:  z::  zz  z::  zz  zz  z::  zz  zz  zz  zz  t:::  zz  z::  zz:  tr.  zz  zz  tj:  zr, 

0008 

c 

0009 

c 

0010 

c 

description: 

0011 

c 

0012 

c 

OPUSE  DETERHINES  THE  OPTIHUH  USE 

FACTORS  FOR  THE  CURRENT  DATA* 

0013 

c 

AND  DISPLAYS  THESE  OALUES  ALONG 

WITH  THE  FEASIBILITY  RANKINGS 

0014 

c 

AND  TOTAL  COST  FOR  RECLAMATION. 

ALL  VALUES  ARE  RANKED  FROM 

0015 

c 

BEST  TO  WORST. 

0016 

c 

OPUSE  IS  SCHEDULED  THROUGH  CLAIM 

SWAP  CONTROL  VIA  PROGRAM  OPUSX 

0017 

c 

0018 

c 

CALLING  sequence: 

0019 

c 

0020 

c 

CALL  OPUSE 

0021 

c 

0022 

c 

arguments:  none 

0023 

c 

0024 

c 

ACCESSED  by: 

0025 

c 

CLAIM 

0026 

c 

RCLAM  (SEAMPLAN) 

0027 

c 

0028 

c 

SUBROUTINES  SCHEDULED: 

0029 

c 

0030 

c 

BELL  (TCS) 

0031 

c 

ERASE  <TCS) 

0032 

c 

HOME  (TCS) 

0033 

c 

TINPT  (TCS) 

0034 

c 

0035 

c 

LOCAL  variables: 

0036 

c 

0037 

c 

AVGR  FEASIBILITY  RANKINGS 

0038 

c 

EKON  - TOTAL  RECLAMATION  COSTS 

0039 

c 

OPTM  “ OPTIMUM  USE  FACIORS 

0040 

c 

IANS  - ANSWER  CELL 

0041 

c 

0042 

c 

0043 

c 

author:  . ORVILLE  D. 

GREEN 

0044 

c 

( • 

0045 

c 

CLAIM  RELEASE  1.0  - APRIL 

ly  1980 

004  6 

c 

0047 

c 

0048 

c 

li 

II 

!! 

1! 

il 

!1 

1! 

1! 

n 

li 

!! 

!! 

I! 

It 

II 

I! 

11 

I! 

1! 

II 

1! 

I! 

11 

1! 

I! 

1! 

!! 

I! 

!! 

!! 

1! 

II 

1! 

!! 

II 

II 

il 

11 

il 

il 

1! 

1! 

I! 

n 

il 

II 

II 

11 

II 

1! 

II 

II 

II 

II 

II 

II 

II 

II 

11 

li 

I! 

1! 

11 

II 

i! 

II 

!1 

U 

0049 

c 

0050 

c 

0051 

SUBROUTINE  OPUSE 

0052 

c 

0053 

c 

0054 

c 

TEKTRONIX  COMMON 
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0055  C 

0056 

0057  C 

0058  C 

0059  C 

0060 

0061  C 

0062  C 

0063  C 

0064 

0065 

0066 

0067 

0068 

0069 

0070  C 

0071  C 

0072  C 

0073 

0074 
00  75 

0076  C 

0077  C 

0078  C 

0079 

0080 
0081 

0082  C 

0083  C 

0084  C 

0085 

0086 

0087 

0088  C 

0089  C 

0090  C 

0091 

0092 

0093 

0094  C 

0095  C 

0096  C 

0097 

0098 

0099 

0100 
0101 
0102 

0103  C 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


COMMON  ITEK  (45) 

LOGICAL  UNITS  AND  COMMON  LOCATION 
COMMON  IARRY(5) y IARY2C5) y LLR y LUF y LUL 
POINTERS 


COMMON  EXIT  y IANM(3)  y ICLI  (2)  y IGEN(3)  y I6Rk'<5) 

COMMON  lOPTN  y I00R<7) y IPNTR  y IS0C(6) y ISUB<8) 

COMMON  ISUR<6)  y IT0P(9)  y I0EG(2)  y LEX  IT  yl.UO 

COMMON  MODE  yNANM  ?NCLI  yNGEN  yNGRN 

COMMON  NOOR  yNSECTS  yNSOC  yNSUD  yNSUR 

COMMON  NTOP  y NO  yNOEG 

GRADING  PARAMETERS 

common  area (5) yBENLEN(5y 10) yBENWI (5y 10) y C060 y GCPA ( 5 ) 
COMMON  GRB0BS<5) yHWHT(5y 10) y HNSLl ( 5 y 10 ) y NSPP ( 5 ) y PCEQ19 < 4 ) 
common  PERCNi (5y 10) yPEHCPY(5) yREH00L(5) r SL0PE(5y 10) y WBP 

CATEGORY  TEXT 

COMMON  ANlMC23y 13) yCLMA( 13y 13) yGBES( 15y 13) y GOHY < 22 y 1 3 ) 
COMMON  OMBD  < 1 1 y 1 3 ) y SBSL ( 1 3 ) y SCEC ( 33  y 1 3 ) y SWH Y ( 4 4 y 1 3 ) 
COMMON  TPSL(49y 13) y MGTA( 15r 13) 

EXPECTATION  VALUES 


COMMON  AN I MAL ( 1 3 y 6 ) y CL I MAT ( 8 y 6 ) y GENDES ( 8 y 6 ) y GRWHYD ( 1 9 y 6 ) 
COMMON  0VRBDN(28y 6) y SOCECN ( 29 y 6 ) y SUBSOI ( 30 y 6 ) y SURHYD ( 23 y 6 ) 
COMMON  T0PS0I(33y6) y VEGETA ( 10 y 6 ) 

CATEGORY  RESPONSES 


COMMON  RANIMA<3) yRCLIMA(2) y R6ENDE ( 3 ) y RGRUHY ( 5 ) 
COMMON  R0VRBD(7y 10) y RSOCEC ( 6 ) y RSUBSO ( 8 ) y RSURHY ( 6 ) 
COMMON  RT0PS0(9) yRVE6ET(2) 


FEASIyTECONyOPUSE  SUBSYSTEM  PARAMETERS 


COMMON  CAAHMyCABAHyCABFN<3) yCABFP(3) yCABHM 

COMMON  CABS (2) y CAC y CACP y CADF y CADH 

COMMON  CADS  y CAEAF  y CAHSAF  y CAHSTS y CAI P 

COMMON  CAR3FC  y CASF  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y FAVG ( 5 ) y PF6TSP  y PFAC  y RCLTEC  < 29  y 34 ) 

COMMON  TCAR(5) yTHICK(lO) y THKTS y TTL < 40 ) 

I NT  EGER  EX I T y CLMA  y ODES  y GWHY  y OVBD  y SBSL 
INTEGER  SCEC  y SWH Y y TPSL  y VGTA  y ANI M 
INTEGER  CLIMAT  y GENDES y GRWHYD y OVRBDN 
INTEGER  SOCECN y SUBSOI y SURHYD yTOPSOI 
I N T L G E R V E G E T A y N 1 1 ) A L 

INTEGER  RCL IMA  ? RGENDE  y R6RWHY  y ROVRBD  y RSOCEC 
1 ^F^  EGER  RSUBSO  y RSURH Y y RT  OPSO  y RVEGE T y RANI MA 
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0111 

INTtOER  RCLTECtTTL 

0112 

C 

Oll.i 

INTEGER  COMMON  (1) 

0114 

EQUIVALENCE  (COMMON  (l)y  ITEM  (D) 

0115 

EQUIVALENCE  (lARRY  (1),  LUT) 

0116 

EQUIVALENCE  (1ARY2  (1),  ISTRK) 

0117 

EQUIVALENCE  (IARY2  <2)jISECT) 

0118 

EQUIVALENCE  (IARY2  (3)r  ICODE) 

0119 

EQUIVALENCE  (IARY2  (4)y  LEN) 

0120 

c 

0121 

LOGICAL  LER 

0122 

DIMENSION  0PTM<5) tEK0N(5) j AVGR(5) 

0123 

INTEGER  ALTN  (6^4) 

0124 

COMMON  /ALTRN/  ALTN 

0125 

c 

0126 

c 

FILL  DUMMY  ARRAYS 

0127 

c 

0128 

IF (LER)  CALL  ERASE 

0129 

IF  (LER)  CALL  HOME- 

0130 

DO  5 1=1 r 5 

0131 

AVGR(l)  = FAVG(I) 

0132 

5 

EKON(I)  = TCAR(I) 

0133 

c 

0134 

c 

FIGURE  THE  OPTIMUM  USE  FACTORS 

0135 

c 

0136 

DO  10  1=1? 5 

0137 

IF(EKON(I) *LE*0» ) GOTO  9 

0138 

OPTM(I)  = FAVG(I)  )K  1000.  / EKON(I) 

0139 

GOTO  10 

0140 

9 

AVGR(I)  = “1. 

0141 

GPTM(I)  = -1. 

0142 

EKON(I)  = 1001100. 

0143 

10 

CONTINUE 

0144 

c 

0145 

t; 

NOW 

PRINT  IT  our  tt  i:feasiy4n:tecon:^l:opuse 

0146 

c 

0147 

WR1TE(LUL?34)  TTL 

0148 

N=0 

0149 

NN  = 0 

0150 

13 

N=N+1 

0151 

AMI  = AMAXKAVGRd)  jAV6R(2)?AVGR(3)?AVGR(4)?AVGR(5)) 

0152 

AM2  = AMINl(EK0N(i)yEK0N(2)jEK0N(3)?EK0N(4)?EK0N(5)) 

0153 

AM3  = AMAX1(0PTM(1)?0PTM(2)?0PTM(3)?0PTM(4)?0PTM(5)) 

0154 

DO  20  J=l,5 

0155 

1F(AM1 .EQ.AV6R( J) ) 15?20 

0156 

15 

AVGR(J)  = -1. 

0157 

I = J 

0158 

GOTO  21 

0159 

20 

CONTINUE 

0160 

21 

DO  25  J=l?5 

0161 

IF(AM3.EQ.0PTM( J) ) 22? 25 

0162 

oo 

□PTM(J)  = -1. 

0163 

L=J 

0164 

GOTO  26 

0165 

^%C.' 

CONTINUE 

0166 

26 

DO  30  J=l?5 

?07 


U]  r.n  cn 


0167  IF(AM2*EQ*EK0N( J) ) 27>30 

0168  27  EKON(J)  = +1001100* 

0169  K=:J 

0170  GOTO  31 

0171  30  CONTINUE 

0172  31  ir(AH2*EQ* 1001100* ) GOTO  40 

0173  NN  = NN  + 1 

01 74  WRITE  ( LUL  y 3G ) NN ? < ALTN ( I t J ) y 1 » 4 ) ? AN  1 y 

017U  t NN»  (ALTNCK?  J)  y J=:1j4)  yAN2yNNy  (ALTN(Ly  J)  ? J=ly4)  yAN3 

0176  IE(N*6E*U)  GOTO  40 

0177  GOTO  13 

0178  C 

0179  34  FORMATClHly  lXy40A2j//yl5X*)K)^.)f:  CONPARXSONS  AND  0PTIMUH*1X 

0j80  )t:*USE  f- ACTORS  y 

0181  ){c3/y  SX'FEASIBILITY  RANKING*  8X“C0ST  PER  ACRE"  9X"0PriNUN  USE"/y 

0182  tbX'‘ • 8X" " 9X" "//) 

0183  C 

0184  35  FORNA  f ( IXy 11 “ ) * " 4A2 y FI 0 * 3 ? 3X y 1 1 " ) ♦ " 4A2 y FIO * 2 y 4X y 

0185  3^11")*  "4A2yF10*5) 

0186  C 

0187  40  IF<LUL*NE*LLIT*OR*  <NOT*LER)  RETURN 

0188  WRITE(LUTy45) 

0189  45  FORNAl (5X"HIT  THE  RETURN  KEY  TO  CONTINUE 

0190  CALL  DELL 

0191  CALL  TINPT(IANS) 

0192  IF  < IARRY(2)  *NE*  3 ) CALL  ERASE 

0193  CALL  HONE 

0194  RETURN 

0195  END 

0196  END$ 


f • 
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&OMRBD  1=00004  IS  ON  CROOOlli  USING  00067  BLKS  R=0000 


0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 


FTN4 


SUBROUTINE  OMRBD 


C FULL  DISPLAY — CATEGORY  5 / OVERBURDEN 

C 

C LEVEL  2 
C 

C OVRBD  IS  ACCESSED  BY  EIFD  TO  SCHEDULE  USER  INPUTS  AND 
C EDITS  TO  CATEGORY  RESPONSES?  AND  USER  EDITS  TO  EXPECTATION 
C OF  SUCCESS  VALUES  FOR  CATEGORY  5 - OVERBURDEN?  USING  FULL 


C DISPLAY* 

C 

C THE  NETHOD  HERE  DIFFERS  SOMEWHAT  FROM  7 HE  GENERAL  "FULL  DISPLAY” 
C METHODOLOGY  EMPLOYED  BY  THE  OTHER  ENVIRONMENTAL  CATEGORIES  IN 
C THAT  UP  TO  10  SETS  OF  RESPONSES  MAY  BE  DEFINED.-  THUS?  THE  ‘EDIT 
C RESPONSE'  MODE  REQUIRES  THAT  THE  USER  SPECIFY  THE  LITHOLOGIC 
C UNIT  NUMBER  OF  HIS  EDIT  IN  ADDITION?  THE  USER  HAS  THE  OPTION 
C OF  ADDING  TO  OR  SUBTRACTING  FROM  THE  LAST  LITHOLOGIC  UNIT 
C ENTERED  (PROVIDED?  OF  COURSE?  THAT  THE  NUMBER  IS  NOT 
C GREATER  THAN  10  OR  LESS  THAN  1)* 

C 

C THE  'INPUT  MODE'  REQUIRES  THAT  THE  'LEXIT'  POINTER  BE 
C CHECKED  - IF  ONE?  WE  START  AT  THE  FIRST  LITHOLOGIC  UNIT? 

C OTHERkUSE?  7HE  CURRENT  LITHOLOGIC  UNIT  NUMBER  IS  USED* 

C 


0025  C 

0026  C THE  CALLING  SEQUENCE  IS  CALL  OVRBD 

0027  C 


0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 

0053 
0 0 5 4 


C 

c 

c 

c 

c 

c 

c 

c 

C 

c 

c 

c 

c 

c 

c 


c 

c 

c 


c 

c 

c 

c 

c 


c 

c 

c 


OVRBD  USES  THE  TCS  ROUTINES  : BELL ? ERASE ? HOME ? AND  TINPT 

THE  LOCAL  VARIABLES  ARE  I 

CHNG  ~>  ARRAY  CONTAINING  HEADING  LETTER  CHANGES 

lADD  ->  SET  TO  ONE  IF  USER  WANTS  TO  ADD  A LITHOLOGIC 

UNIT  DURING  EDIT  MODE 
IANS  ->  ANSWER  CELL 

I CHAR  “>  TINPT  RETURN  CELL 

II  “>  '!•  INDEX  C (I?J)  ~J  TO  OVRBDN  ARRAY 

lOLD  -•>  PRE-EDIT  CATEGORY  RESPONSE  VALUE 

LUORN  ->  LAND  USE  OPTION  REFERENCE  NUMBER 

1- >  CROPLAND 

2- >  NATIVE  VEGETATION 
3“>  WILDLIFE 

4->  WATER  RECREATION 
'■  5->  HIGH  USE 
6">  OTHER 

NN  ->  HEADING  NUMBER 

NO  ->  CURRENT  LITHOLOGIC  UNIT  NUMBER- 

NEXT  ->  NEXT  LITHOLOGIC  UNIT  NUMBER 

OVRBD  IS  SWAPPED  IN  BY  PROGRAM  OVRBX 


THIS  ROUTINE  WAS  WRITTEN  BY  GREEN 


C CLAIM  RELEASE  1*0  - APRIL  1?  1980 
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0055 

0056 

0057 

0058 

0059 

0060 
0061 
0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 
00  79 
0080 
0081 
0082 
OOS3 

0084 

0085 

0086 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 
0101 
0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


c 

c 

c 


c 

c 

c 


c 

c 

c 


c 

c 

c 


c 

c 

c 


c 


TEKTRONIX  COMMON 
COMMON  ITEK  (45) 

LOGICAL  UNITS  AND  COMMON  LOCATION 
COMMON  IAF<RY(5)  y I ARY2  < 5 ) y LER  y LUE  y LUL 


POINTERS 


COMMON  EXIT  y IANM(3) y ICLI ( 2 ) y I6EN ( 3 ) y IGRW(5) 

COMMON  lOPTN  y 100R(7) y IPNTR  y 1S0C(6) y ISUB(8) 

COMMON  ISUR<6) ? 1T0P(9) y IUEG(2) y LEX IT  yLUO 
COMMON  MODE  yNANH  yNCLl  yNGEN  yNGRW 

COMMON  NOOR  yNSECTS  yNSOC  yNSUB  yNSUR 

COMMON  NT OP  yNU  yNOEG 

GRADING  PARAMETERS 

COMMON  AREA(5) y BENLEN ( 5 y 10 ) y BENWI ( 5 y 10 ) y COGO y GCPA < 5 ) 
COMMON  GRDOBS  ( 5 ) y f I W(-|T  ( 5 y 1 0 ) y HU'SL  1 ( 5 y 1 0 ) y NSPP  ( 5 ) y PCEQ 1 9 ( 4 ) 
COMMON  PERCNl (5y 10) yREHCPY<5) yREH00L(5) y SLOPE ( 5 y 10 ) y UBP 


CATEGORY  TEXT 


COMMON  ANIM(23y 13) yCLMA(13y 13) y6DES( 15y 13) yGWHY(22y 13) 
COMMON  OOBD ( 1 1 y 1 3 ) y SBSL ( 1 3 ) y SCEC ( 33  y 1 3 ) y SONY  < 44  y 1 3 ) 

COMMON  TPSL(49y  13)  yOGTAdSy  13) 

EXPECTATION  OALUES 

COMMON  ANIMAL(13y6) yCLlMAT (8y6) y GENDES ( 8 y 6 ) y GRWHYD < 19 y 6 ) 
COMMON  0VRBDN(28y6) yS0CECN(29y6) y SUBSOl ( 30 y 6 ) y SURHYB < 23 y 6 ) 
COMMON  T0PS0I(33y6) y OEGETA ( 10 y 6 ) 


CATEGORY  RESPONSES 


COMMON  RANIMAC3) yRCLlMA(2) yRGENDE<3) ?R6RUHY(5) 
COMMON  R0URBD(7y 10) yRS0CEC(6) y RSUBS0(8) yRSURHY(6) 
COMMON  RT0PS0(9) yR0E6ET(2) 

FEASIylECONyOPUSE  SUBSYSTEM  PARAMETERS 


COMMON  CAAHM  y CABAH  y CABFN ( 3 ) y CABFP ( 3 ) y CAHBM 

COMMON  CABS ( 2 ) y CAC  ? CACP  y CABF  r CADH 

COMMON  CADS  y CAEAF  y CAHSAF  y CAHSTS  y CA 1 P 

COMMON  CAR3FC  y CASF  y CASNC  y CSTES  y CSTRM 

COMMON  CSI RP  y FAOG  < 5 ) y PFSTSP  ? PFAC  y RCLTEC  < 29  y 34 ) 

COMMON  ICAR  < 5 ) y THICK  < 10 ) y THKTS  y TTL ( 40 ) 


I NTEGER  EXI T y CLMA  y GDES  y GWHY  y DUBD  y SBSL 
INTEGER  SCEC  y SUH Y ? TPSL  ? UGTA  y ANI M 
INTEGER  CLIMAT  y GENDES  y GRUHYD  y OORBDN 
INTEGER  SOCECNr SUBSOl ? SURHYD y TOPSOI 
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0111 

0112 

0113 

0114 

0115  C 

0116 

0117 

0118 

0119 

0120 
0121 
0122 

0123  C 

0124 

0125 

0126  C 

0127 

0128  C 

0129  C 

0130 

0131 

0132 

0133  C 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143  C 

0144  C 

0145  C 

0146  C 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 
0161 
0162 

0163  C 

0164 

0165 

0166 


INTEGER  VEGETA r ANIMAL 

INTEGER  RCLIMAyRGENDEyRGRWHYrROVRBLijRSOCEC 
INTEGER  RSUBSO,RSURHY>RTGPSO?RVEGET»RANIMA 
INTEGER  RCLTECyTTL 


INTEGER  COMMON  <1) 

EQUIVALENCE  (COMMON  <l)y  ITEK  (1)) 
EQUIVALENCE  (lARRY  <l)r  LOT) 
EQUIVALENCE  (1ARY2  (l)y  ISTRK) 
EQUIVALENCE  (IARY2  (2)»  ISECT) 


EQUIVALENCE  (IARY2  <3)j  ICODE) 
EQUIVALENCE  (IARY2  (4)j  LEN) 


LOGICAL  LER 
INTEGER  CHNGC5) 


BATA  CHNG/2H  D»2H  E?2H  Fj2H  Gj2H  H/ 

INITIALIZE  NOj  IABB?  IPASS 

NO  = 0 
I ADD  ==  0 
IPASS=:0 

DISPLAY  MODE 

1 IF  (.NOT. LER  ) GOTO  5 
CALL  ERASE 
CALL  HOME 

5 GOTO  (10>20j30)  MODE 

10  WRITE  (LUTylOlO) 

GOTO  40 

20  WRITE  (LUT?2010) 

GOTO  40 

30  WRITE  (LUTy3010) 

GIVE  DIRECTIONS  FOR  INPUT  MODE 

IF  EDIT  RESPONSE  MODE>  MAKE  SURE  THAT  WE 

HAVE  DATA  TO  EDIT 

IF  EDIT  EXPECTATION  MODE?  PROCEED  NORMALLY 

40  IF(M0DE.NE.2)  GOTO  41 

IF(NU.GE.l)  GOTO  50 
WRITE(LUTj 1112) 

IF(LER)  WRITE(LLiTyllll) 

IF (LER)  CALL  BELL 
IF(LER)  CALL  TINPT(ICHAR) 

RETURN 

41  IF(M0DE.EQ.3)  GOTO  100 
WRITE(LUfy 1110) 

IF(LER)  WRITE(LUT  y 1111 ) 

IF (LER)  CALL  BELL 
IF (LER)  CALL  TINPT(ICHAR) 

IF ( IPASS. NE.O)  GOTO  200 
1F(LEXIT.NE.1  ) NO=^NLI 
IF(NO.EQ.O)  GOTO  200 

G0T0(210y 300y 400y500y600y 700y800y820)  LEXIT 

EDIT  RESPONSES 

50  WRITE  (LUTy2020)  NU 

51  R£AD(LUTy)fO  IANS 

IF  (lANS.EQ.O)  REIURN 
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0167 

0168 

0169 

0170 

0171 

0172 

0173 

0174 

0173 

0176 

0177 

0178 

0179 

0180 

0181 

0182 

0183 

0184 

0185 

0186 

0187 

0188 

0189 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

0197 

0198 

0199 

0200 

0201 

0202 

0203 

0204 

0205 

0206 

0207 

0208 

0209 

0210 

0211 

0212 

0213 

0214 

0215 

0216 

0217 

0218 

0219 

0220 

0221 

0222 


IF  (IANS*GE.1.AND<.  IANS*LE*3>  GOTO  (60?  70^80)  IANS 
ORITE  (LOT? 1200) 

GOTO  51 

C ADD  A LITHOLOGIC  UNIT 

60  IF  (NU*LT«10)  GOTO  65 
WRITE  (LUT?2070) 

GOTO  50 

65  NO  NU  + 1 
lADD  1 
NODE  ==  1 
GOTO  210 

C SUBTRACT  LITHOLOGIC  UNIT 

70  IF  (NU.GT*1)  72?71 

71  WRITE  (LUT?2060) 

GOTO  50 

72  DO  73  I 1?  7 

73  ROORBD(I?NU)  =^'  0 
IF(LER)  CALL  ERASE 
IF(LER)  CALL  HOME 
WRITECLin  ?2061 ) NU 
NU  =:  NU  - 1 

GOTO  850 

C USER  3MPUT  ->  LITHOLOGIC  UNIT  NUMBER  OF  EDIT 

80  WRITE  (LUT?2030) 

READ(LUT?)fO  NO 

IF  (N0*LE»NU.AND.N0*GE*1)  GOTO  100 
WRITE  <LUT?2050)  NU 
GOTO  80 

C USER  INPUT  ">  EDIT  HEADING 

100  WRITE  (LUTj2040) 

101  READCLUT ?1220)  IANS 


IF 

(1ANS.EQ»2HA 

) 

GOTO 

210 

IF 

(IANS*EQ.2HB 

) 

GOTO 

300 

IF 

< IANS«EQ*2HC 

) 

GOTO 

400 

IF 

(IANS*EQ»2HD 

) 

GOTO 

500 

IF 

< IANS*ECn2HE 

) 

GOTO 

600 

IF 

( IANS«EGK2HF 

) 

GOTO 

700 

IF 

<IANS*EQ.2H6 

) 

GOTO 

800 

IF 

(IANS*ECK2HH 

) 

GOTO 

820 

IF 

<IANS*EQ»2HN0) 

RETURN 

TE 

(LUT? 1200) 

GOTO  101 

C EDIT  EXPECTATIONS 

C USER  INPUT  “>  SUBHEADING  NUMBER 

130  WRITE  (LUT?3020) 

131  READ<LL1T?3^)  II  " 

GOTO  175 

135  II"II  T L 

C USER  INPUT  ->  LAND  USE  OPTION  REFERENCE  NUMBER 

136  WRITE  (LUT?3030) 

138  READ(LUTy)(0  LUORN 

IF  <LUORN*GE* 1 .AND*LU0RN.LE.6)  GOTO  137 
WRITE  (LUT?1200) 
goto  138 

C USER  INPUT  “>  EXPECTATION  UALUE 

137  WRITE  (LUT?3035) 
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022:3 

0224 

0225 

0226 

0227 

0228 

0229 

0230 

0231 

0232 

0233 

0234 

0235 

0236 

0237 

0238 

0239 

0240 

0241 

0242 
024  3 

0244 

0245 

0246 

0247 

0248 


C 


C 

C 


C 


139  REALKLU  r T>^;)  OORBDN  ( 1 1 , LUORN ) 

IF  ( OORBDN  < 1 1 ? LUORN ) ♦ GE  * 0 ♦ AND  < OVRBDN (II, LUGRN ) ♦ LE  * 4 ) 
+ GOTO  850 
WRITE  (LOT, 3040) 

GOTO  139 

EBIT  CATEGORY  RESPONSES 

150  I OLD  = ROORBD<NN?NO) 

151  WRITE  <LUTj2045)  IOLD 
GOTO  173 

INPUT  CATEGORY  RESPONSES 
USER  INPUT  “>  ROORBDCNNf NO) 


170  WRITE  (LUTy2000) 

173  READ(LUTj^)  RG0RBD(NN»N0) 
II=ROMRBD(NNjNO) 


IF  (II.EQ^O)  goto  <950»176)  NODE 

175  IF  ( II *6E* 1 .AND^II .LE. IGUR  (NN)  ) 

+ GOTO  (900^850? 135)  NODE 

176  WRITE  <LUTyl200) 

GOTO  (173yl73yl31)  NODE 

DISPLAY  HEADING  A NUHBER  OF  ROCKS 
200  NO  = NO  T 1 
210  NN  = 1 


IF(M0DE.NE*1*AND*LER)  CALL  ERASE 
IF(HODE»NE. 1 .AND^LER)  CALL  HONE 
IF (MODE *NE* 3)  WRITE  <LUT?1115)  NO 


WRITE  (LUfyiOOO)  (00BD(l*I)yI=^lyl3) 


0249 

0250 

0251 

0252 

0253 

0254 

0255 

0256 

0257 

0258 

0259 

0260 


WRITE  (LUTyl020) 

WRITE  (LUT? 1050)  ( (OOBD(K» I ) ? 1=1 t 13) yK=2y 3) 

J=1 

L=J  " 1 
DO  215  K=4j7 

WRITE  (LU I ? 1100)  (OOBDCKy I) ? 1=1 ? 13) y (OORBDN( Jy 1 ) y 1=1 y6) 
215  J=J  T 1 

220  GOTO  (170y 150y 130)  MODE 
C DISPLAY  HEADING  B -;>  THICKNESS  OF  UNIT 

300  GOTO  <330y 320y 310)  MODE 
310  WRITE  (LUTy3050) 

GOTO  100 


0261 

0262 

0263 

0264 

0265 

0266 

0267 

0268 

0269 

0270 

0271 

0272 

0273 

0274 

0275 

0276 

0277 

0278 


C 


320 

330 


400 


410 


WRITE  (LUTy2080)  THICK  (NO) 

WRITE  (LUfyl210) 

READ(LUTy)^)  THICK  (NO) 

IF  (THICK  (N0)*GE.5)  GOTO  ( 400 y 850)  MODE 


WRITE  (LUfyl215) 
GOTO  330 

DISPLAY 

NN  = 2 

J = lOOR  (1)  + 1 
L=J  - 1 

IF  (*NOT*LER) 
CALL  ERASE 
CALL  HOME 
WRITE  (LUTylOOO) 
WRITE  (LUTyl020) 
WRITE  (LUTyl050) 
DO  415  K=13yl8 
WRITE  (LUryllOO) 


HEADING  C -;>  TEXTURE 


GOTO  410 

(OOBDdy  I)  y I = ly  13) 


( (OOBD(Ky I ) y 1=1 y 13) y K=8y 10) 


(TPSL(Ky I ) y 1=1 y 13) ? (OORBDN( Jy I ) 


I = 1 y 6 ) 
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0279  415  J=J  + 1 


0280 

0281 

0282 

0283 

0284 

0285 

0286 

0287 

0288 

0289 

0290 

0291 

0292 

0293 

0294 

0295 

0296 

0297 

0298 

0299 

0300 

0301 

0302 

0303 

0304 

0305 

0306 

0307 

0308 

0309 

0310 

0311 

0312 

0313 

0314 

0315 

0316 

0317 

0318 

0319 

0320 

0321 

0322 

0323 

0324 

0325 

0326 

0327 

0328 

0329 

0330 

0331 

0332 

0333 

0334 


WRITE  (LUTs 1100)  ( OOBD ( 1 1 y I ) y 1=1 r 13 ) ^ (OORBDN( Jy I) y I=ly6) 


GOTO  220 

DISPLAY 

HEADING  D -> 

BULK  DENSITY 

500 

IF  (*NOT*LER) 

GOTO  510 

CALL  ERASE 
CALL  HOME 

510 

WRITE  (LUTy 1000) 

(OVBD( 1 y 1 ) y 1= 

=lyl3) 

NN=3 

J=IDOR  (1)  + lOOR  (2)  4 1 
L=J  - 1 

WRITE  (LUTyl020) 

WRITE  (LUT?1051) 

WRITE  (LUTyl050) 

DO  515  K=26?27 
WRITE  (LUTyllOO) 

515  J=J  T 1 
GOTO  220 

C DISPLAY 

600  IF  <*NOT*LER) 

CALL  ERASE 
CALL  HOME 
WRITE  (LUlylOOO) 

610  WRITE  (LOT? 1020) 

WRITE  (LUTyl051) 

NN=4 

J=10UR  (1)  T lOOR  <2)  T lOOR  (3)  + 1 
L=J  - 1 

DO  615  K=29y33 

WRITE  ( LOT y 1100)  (TP8L(Ky 1 ) y 1=1 y 13) y (OURBDNC Jy I) y 1=1 y6) 
615  J=J  T 1 
GOTO  220 

C DISPLAY  HEADING  F ~>  SODIUM  ADSORPTION  RATIO 

700  NN=5 

J=IOOR  (1)  T lOOR  (2)  + lOOR  (3)  + lOOR  (4)  + 1 
L=J  - 1 

IF  («NOT*LER)  GOTO  710 
CALL  ERASE 
CALL  HOME 

WRITE  (LUTy 1000)  (OMBD< 1 y I ) y 1=1 y 13) 

710  WRITE  (LUTy 1020) 

WRITE  (LUTy 1051)  CHN6  (3)y  ( TPSL ( 34 y I ) y 1=2 y 13 ) 

WRITE  (LUfylOSO)  (TPSL(35yI) y I=lyl3) 

DO  715  K=36y39 

WRITE  (LUTy 1100)  (TPSL(Ky I ) y 1=1 y 13) y (OORBDN( jy I ) y 1=1 y6) 
715  J=J  1 
GOTO  220 

C DISPLAY  HEADING  G ->  AVAILABLE  NITROGEN 

800  NN=6 

J=IOVR  (1)  T lOVR  (2)  + lOVR  (3)  + lOVR  (4)  + lOVR  (5)  T 1 
L=J  - 1 

IF  (♦MOT^LER)  GOTO  810 
CALL  ERASE 
CALL  HOME 

810  WRITE  (LUlylOOO)  ( OVBD ( 1 y 1 ) y 1 = 1 y 1 3 ) 

WRITE  (LUT  y 1020) 


CHN6  ( 1 ) y (TPSL(24y I ) y 1=2 y 13) 
(TPSL(25yI)yI=lyl3) 

( TPSL ( K y I ) y I = 1 y 1 3 ) y ( OVRBDN (Jyl)yl  = ly6) 

HEADING  E ->  SALINITY 
GOTO  610 

(0VBD(lyI)yI=lyl3) 

CHNG  (2)y  (TPSL(28y I) yl=2y 13) 
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0335 

0336 

0337 

0338 

0339 

0340 

0341 

0342 

0343 

0344 

0345 

0346 

0347 

0348 

0349 

0350 

0351 

0352 

0353 

0354 

0355 

0356 

0357 

0358 

0359 

0360 

0361 

0362 

0363 

0364 

0365 

0366 

0367 

0368 

0369 

0370 

0371 

0372 

0373 

0374 

0375 

0376 

0377 

0378 

0379 

0380 

0381 

0382 


0384 

0385 

0386 

0387 

0388 

0389 

0390 


WRITE  (LLITj1051)  CHM6  (4)?  ( TPSL  ( 40  ? 1 ) ? 1=^2  * 1 3 ) 

WRITE  (LUfylOSO)  (TPSL(41yl)>I=lyl3) 

DO  815  K=^42?44 

WRITE  ( LUT  j 1 100 ) ( TPSL ( K ? I ) r 1 = 1 y 13 ) r ( OVRBDN ( J y 1 ) y 1 = 1 y 6 ) 
815  J=J  + 1 
GOTO  220 

C DISPLAY  HEADING  H ~>  AVAILABLE  PHOSPHORUS 

820  NN=7 

J=10VR  (1)  -f  lOVR  <2)  T lOOR  (3)  + lOVR  <4)  + lOVR  (5)  + 

+ lOVR  (6)  -f  1 
L=J  “ 1 

IF  <.NOT*LER>  GOTO  825 
CALL  ERASE 
CALL  HOME 

WRITE  (LUTylOOO)  C OUBD ( 1 y I ) y 1=1 y 1 3 ) 

825  WRITE  (LUTyl020) 

WRITE  <LUTyl051)  CHNG  (5)y  ( TPSL ( 45 y I ) y 1 =2 y 1 3 ) 

WRITE  < LUT? 1050)  (TPSL(46y 1 ) y 1=1 y 13) 

DO  830  K=47y49 

WRITE  (LUT y 1100)  (TPSL(Ky I ) y 1=1 y 13) y (OVRBDN( Jy I ) y 1=1 y 6) 
830  J=J  T 1 
GOTO  220 

C USER  INPUT  ->  GOTO  NEXT  LITHOLOGIC  UNIT  ? 

835  NEXT  = NO  -f  1 

IF  (NEXT*6T»10)  GOTO  840 
WRITE  (LUTyll20)  NEXT 
READ(LUTy 1220)  IANS 

IF  (IANS*NE\2HYE)  GOTO  840 
IPASS=i 
GOTO  200 

C DONE*FOR  INPUT  MODEy  RETURN  OTHERWISE  FIX  MODE 

840  IF  (IADD,EQ*0)  843y  841 

841  MODE  = 2 
843  NU  = NO 

IF  (IADD*EQ.O)  RETURN 

C EDIT  MODE  ->  MORE  CHANGES  ? 

850  WRITE  < LUT y 3060) 

READ < LUT y 1220)  IANS 

IF  <IANS.NE»2HYE)  RETURN 
GOTO  (SOylOO)  MODE  - 1 

C INPUT  MODE  ->  DIRECT  TO  PROPER  HEADING 

900  GOTO  ( 300 y 500 y 600 y 700 y 800 y 820 y 835)  NN 
C USER  WANTS  OUT  ->  SET  EXIT  TO  ZERO  AND  RETURN 

950  EXIT  = 0 
NU=NO 
RETURN 

C FORMAT  S1ATEMEN7S 

1000  FORMAT  (13A2y44  < “ )^  * ) y / y 26X  y ‘ y 

IclOXy  ’STA^/DARD  EXPECTATIONS*  y 1 IX  y * )^;  * y / y 
^26Xy44  <•){■'*)  y/y26Xy  * 5^CROP:4c  * y 2X  y 

NATIVE*  y2Xy  *){CWILD>k"  r2Xy  “WATER*  y3Xy 
S • HI  GHXiOTHER^^  * y / y 26X  y 


* . s • ■ 

y vj/-.  y 


t'  > 


1020  FORMAT  (70  ( * * ) ? / y 26X  y * Y * 4X  * * 1 OX  * * 4X  * Y * 1 OX  " Y * 4X  ’ * 5X  * Y * ) 


C 
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0391 

0392 

0393 

0394 

0395 

0396 

0397 

0398 

0399 

0400 

0401 

0402 

0403 

0404 

0405 

0406 
04  07 

0408 

0409 

0410 

0411 

0412 

0413 

0414 

0415 

0416 

0417 

0418 

0419 

0420 

0421 

0422 

0423 

0424 

0425 

0426 

0427 

0428 

0429 

0430 

0431 

0432 

0433 

0434 
04  35 
04  36 

0437 

0438 

0439 

0440 

0441 

0442 

0443 

0444 
0 4 4 5 
04  46 


1050  f-ORMAT  (13A2?  y4Xy  » lOXy  r4Xy  y 
gl0X> 

1051  FORMAT  (A2, 12A2?  *:^cMX")K'' 10X*)f:MX")^"  j 
&10X“:^=:"4X")}c ‘5X')t:"  ) 


1100  FORMAT  (13A2j 


II"  t 


11  ’ 


t 


II"  t 


II 


t "II 


t 


11'  «•) 


1110  FORMAT  < 5X">r«ESCRIBE  OOERBURDEM-BEDROCK  LITHOLOGICAL  UNITS'/y 


S 

%. 

S 

S 


5X"  FIVE  OR  MORE  FEET  THICKy  ABOVE  AMD  BETWEEN  MINABLE'/y 
5X"  DEPOSITS* "//y 

5X">CLASS1FY  ONLY  THOSE  UNITS  THAT  WILL  USUALLY  APPEAR"/y 
5X"  ON  THE  SURFACE  UNDER  THE  CURRENT  MINE  PLAN*"//y 
5X">START  WITH  THE  UPPERMOST  UNIT  AND  PROCEED  DOWNWARD"/y 
5X"  TO  THE  TOP  OP  THE  LOWEST  MINABLE  COAL  SEAM*"//y 
5X*>UP  TO  10  LITHOLOGIC  UNITS  ARE  CURRENTLY  ALLOWED*"/) 


C 


C 


C 


C 


C 


C 


1111  FORMAT("HIT  THE  RETURN  KEY  TO  CONTINUE *♦♦_" ) 

1112  F0RMAT(/5X"S0RRY*  THERE  ARE  NO  DATA  TO  EDIT"/) 

1115  FORMAT  < 5X'N0W  WORKING  ON  LITHOLOGIC  UNIT"I2y/) 

1120  FORMAT  ( 5X“PR0CEED  TO  UNIT  =S^"I2"  ? (YES  OR  NO)  ”>_•) 

1200  FORMAT  (/"YOU  HAVE  TYPED  IN  AN  ILLEGAL  ANSWER* "y 
S/y  "GIVE  HER  ANOTHER  SHOT  ~>  _") 

1210  FORMAT  ( 3X"D<)  THICKNESS  OF  THIS  UNIT?  (FEET)  ->„") 

1215  FORMAT  ( 5X"Y0UR  UNIT  MUST  BE  AT  LEAST  5 FEET  THICK  <•  RE-ENTER *' /) 


C 


C 


C 


1220  FORMAT  (A2) 

2000  FORMAT  ("ENTER  THE  APPROPRIATE'SXy  44  ("){c")y/y 
^•NUMBER  OR  ZERO  TO  QUIT  ->_") 

1010  FORMAT  ( 15X" INPUT  RESPONSES/OVERBURBEN " / ) 


2010  FORMAT  ( 


C 


3010  FORMAT  ( 


1 5X " EDIT  RESPONSES/OVERBURDEN ‘ / ) 

15X ' EDIT  EXPECTATIONS/OVERBURDEN " / ) 


C 


2020  FORMAT  ( 


5X'Y0U  ARE  PRESENTLY  WORKING  WITH  "12"  LITHOLOGIC "/ y 
^5X'UNITS*SELECT  ONE  OF  THE  FOLLOWING  OPTIONS  t'/y 
•^7X"0*)  EXIT  FROM  THIS  OPTION" /y 
S7X‘l*)  ADD  ANOTHER  LITHOLOGIC  UNIT*"/y 
&7X"2*)  SUBTRACT  THE  LAST  LITHOLOGIC  UNIT*"/y 


^7X 


E -2 


) EDIT  CURRENT  DATA*"/y 


S5X'  (ENTER  THE  APPROPRIATE  NUMBER) 


) 


C 


C 


2030  FORMAT  < 5X"IN  WHICH  LITHOLOGIC  UNIT  IS  YOUR  DESIRED  EDIT?'/y 
g5X" ENTER  THE  NUMBER  HERE  ->^') 

2040  FORMAT  ( 5X"IN  WHICH  HEADING  IS  YOUR  DESIRED  EDlT?"/y 
S5X"  (ENTER  AyByCyDyEyPyGyRy  OR  NONE) 
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H7  C 

H8  20^5  FORMAT  < 5X"Y0UR  CURRENT  RESPONSE  IS*I2y/» 

H9  gSX'ENTER  YOUR  NEW  RESPONSE  HERE 

C 

151  2050  FORMAT  < 5X*ERR0R  ~>  ONLY  “12‘  UNITS  DEFINED ♦ TRY  AGAIN."/) 

152  C 

153  2060  FORMAT  (5X"ERR0R  ~>  CAN'T  SUBTRACT  THE  FIRST  UNIT . RE-SELECT ."/ ) 

154  2061  F0RMAT(5X“L1TH0L0GIC  UNIT  "12"  HAS  BEEN  SUBTRACTED") 

155  C 

?56  2070  FORMAT  ( 5X*ERR0R  ->  CAN'T  ADD  ANOTHER  UNIT.TRY  OVER."/) 

157  C 

)5B  2080  FORMAT  ( 5X"CURRENT  THICKNESS  OF  THIS  UNIT  IS  •F7.2"  FEET.") 

!5?  C 

560  3020  FORMAT  < 5X"IN  WHICH  SUB-HEADING  IS  YOUR  DESIRED  EDIT?"/, 

561  &5X"  (ENTER  THE  APPROPRIATE  NUMBER  HERE)  ==>_") 

562  C 

563  3030  FORMAT (/5X" SELECT  THE  LAND  USE  OPTION  YOU  WISH  TO  CHANGE"/ 

564  > IX"  -1-  / -2-  / -3-  / -4-  / -5-  / -6-  /"/ 

565  > 1X"CR0PLAND/NAT . VEG./WILDLIFE/WAT.REC./HIGH  USE/  OTHER/" 

566  >/5X"ENTER  YOUR  SELECTION  HERE  ->  _") 

567  C 

568  3035  FORMAT  ( 5X"ENTER  YOUR  NEW  EXPECTATION  VALUE  HERE  ->„") 

5 69  C 

570  3040  FORMAT  (/?  5X"ERR0R — > YOUR  EXPECTATION  VALUE  MUST  BE"/y 

571  %5X"0»l?2y3y  OR  4 TO  AVOID  INTRODUCING  A BIAS  ->  _") 

5 72  C 

573  3050  FORMAT  < 5X"THERE  IS  NO  EXPECTATION  OF  SUCCESS  VALUE  ASSOCIATED"/? 

574  £5X"WITH  THE  THICKNESS  OF  THE  UNIT.PLEASE  RE-SELECT."/) 

575  C 

576  3060  FORMAT  < 5X"ANY  MORE  EDITS  TO  OVERBURDEN?  (YES  OR  NO)  ->_") 

577  C 

578  C 

579  END 

580  END$ 
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SSOCEC  T=00004  IS  ON  CROGOIS  USING  00045  BLKS  R=0000 


0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 

0053 

0054 


KTN4 


C 


SUBROUTINE  SOCEC 

FULL  DISPLAY — CATEGORY  10  / SOCIO-ECONONICS 


C 

C SOCEC  IS  ACCESSED  BY  EIED  TO  SCHEDULE  INPUTS  AND  EDITS  TO 
C CATEGORY  RESPONSES^  AMD  EDITS  TO  THE  EXPECTATION  OF  SUCCESS 
C OALUES  TO  CATEGORY  10  - SOCIO-ECONOMICS y USING  FULL  DISPLAY 
C 

C THE  CALLING  SEQUENCE  IS  : CALL  SOCEC 

C 

C SOCEC  USES  THE  TCS  ROUTINES  *<  ERASE  AND  HOME 


C 

C 

C 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


c 


c 

c 


THE  LOCAL  OARIABLES  ARE  I 
IANS  “>  ANSWER  CELL 

II  ->  INDEX  C (I?J)  3 TO  SOCECN  ARRAY 

lOLD  ->  PRE-EDIT  CATEGORY  RESPONSE  OALUE 
LUORN  ->  LAND  USE  OPTION  REFERENCE  NUMBER 

l->  CROPLAND 

2~>  NATIOE  UEGETATION 


3“>  WILDLIFE 
4“>  WATER  RECREATION 
5“>  HIGH  USE 
6->  OTHER 

NN  ->  HEADING  NUMBER 


SOCEC  IS  SWAPPED  IN  BY  PROGRAM  SOCEX 


C 

C 

C 

C 

C 

C 

C 

C 

C 

C 


C 

C 

C 


C 


C 

C 


THIS  ROUTINE  WAS  WRITTEN  BY  GREEN 

CLAIM  RELEASE  1*0  - APRIL  ly  1980 


TEKTRONIX  COMMON 


COMMON  ITEK  (45) 

LOGICAL  UNITS  AND  COMMON  LOCATION 


COMMON  IARRY(5) ? IARY2(5) y LERyLUFrLUL 
POINTERS 


COMMON  EXIT  , 1ANM(3) ? ICLI (2) t 1GEN(3) y I6RW(5) 
COMMON  lOPTN  yI00R(7) y IPNTR  y IS0C(6) y I SUB (8) 
COMMON  ISUR<6) y IT0P(9) ? I0E6 ( 2 > y LEXI T yLUO 
COMMON  MODE  yNANM  yNCLI  yNGEN  yNGRW 

COMMON  NOOR  jNSECTS  y NSOC  y NSUB  yNSUR 

COMMON  NTOP  y NU  y NMEG 


GRADING  PARAMETERS 


COMMON  AREA  < 5 ) r BENLEN ( 5 y 1 0 ) y BENW I ( 5 y 1 0 ) y COGO  y GCPA ( 5 ) 
COMMON  GRD0BS<5) yHWHT  <5? 10) y HWSLI ( 5 y 1 0 ) y NSPP < 5 ) yPCEQ19<4) 
COMMON  PERCNT  < 5 y 1 0 ) y REHCP Y < 5 ) y REHUOL ( 5 ) y SLOPE  < 5 ? 1 0 ) y WBP 
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costs 

0056 

0057 

0058 

0059 

0060 

0061 

0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 

0081 

0082 

0083 

0084 

0085 

0086 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 

0101 

0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


C 

C CATEGORY  TEXT 

C 

COMMON  ANIH<23y 13) yCLMA< 13y 13) y GOES (1 5 » 1 3 ) y 6WHY < 22 » 1 3 ) 
COMMON  00BD(llyl3)ySBSL<13)y  BCEC ( 33 y 1 3 ) y SWHY ( 44 y 1 3 ) 
COMMON  TPSL(49y 13) y VGTAClSy 13) 

C 

C EXPECTATION  MALUE8 

C 

COMMON  ANIMAL(13y6) yCLIMAT (8y6) y GENDES < 8 y 6 ) y GRUHYD ( 1 9 y 
COMMON  OORBDN  < 28  y 6 ) y BOCECN ( 29  y 6 ) y SUBSO I < 30  y 6 ) y SURM YD ( 2 
COMMON  T0PB0I(33y6) y0EGETA<10y6) 

C 

C CATEGORY  RESPONSES 

C 

COMMON  RANIMA(3) yRCLlMA<2) yR6ENDE<3) yRGRWHY<5) 

COMMON  R00RBD<7y 10) y RBOCEC < 6 ) y RSUBSO < 8 ) y RSURHY ( 6 ) 
COMMON  RT0PS0<9) yR0EGET<2) 

C 

C EEASIy TECONyOPUSE  SUBSYSTEM  PARAMETERS 

C 

COMMON  CAAHM  y CABAH  y CABI"  N ( 3 ) y CABF  P ( 3 ) y CAHBM 

COMMON  CABS ( 2 ) y CAC  y CACP  y CADE  y CADH 

COMMON  CABS  y CAEAF  y CAHSAF  y CAHSTS  y CAI P 

COMMON  CAR3FC  y CASF  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y FAOG  < 5 ) y PFSTSP  y PF AC  y RCL TEC ( 29  y 34 ) 

COMMON  TCAR(5) yTHICK(lO) yTHKTSy TTL<40) 

C 

I NT  EGER  EX I T y CLMA  y GDES  y GWHY  y OMBD  y SBSL 
INTEGER  SCECySWHYyfPBLyUGTAyANIM 
INTEGER  CLIMAT  yGENBESyGRUHYDyOORBDN 
INTEGER  SOCECNySUBSOIySURHYDy TOPSOI 
INTEGER  VEGETAyANIMAL 

INTEGER  RCL IMA  y RGENDE  y RGRUH Y y ROORBD  y RSOCEC 
INTEGER  RSUBSO  y RSURHY  y RTOPSO  y RVEGET  y RANI MA 
INTEGER  RCLTECyTTL 
C 

INTEGER  COMMON  (1) 

EQUIVALENCE  (COMMON  (l)y  ITEK  (1)) 

EQUIVALENCE  (lARRY  (l)y  LUT ) 

EQUIVALENCE  (IARY2  (l)y  ISTRK) 

EQUIVALENCE  (1ARY2  (2)y  ISECT) 

EQUIVALENCE  (IARY2  <3)y  ICODE) 

EQUIVALENCE  (IARY2(4)y  LEN) 

C 

LOGICAL  LER 
C 

C DISPLAY  MODE 

1 IF  <.NOT*LER)  GOTO  5 
CALL  ERASE 
CALL  HOME 

5 GOTO  <10y20y30)  MODE 
10  URITE  (LUfylOlO) 

GOTO  40 

20  WRITE  (LUfy2010) 

GOTO  40 
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o kj 


0111 

0112 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120 
0121 
0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 
0161 
0162 

0163 

0164 

0165 

0166 


30 

40 


50 

51 


C 


52 

57 

54 


+ 


60 

65 


70 

83 


85 

87 


100 


105 


WRITE  <LUIy3010) 

IF  ( hODE*GT\l)  GOTO  50 
GOTO  ( 100 y 200 ? 300 y 400 y 500^600)  LEXIT 
USER  1NPU1  ~>  EDIT  HEADING 
WRITE  (LUT?2020) 

READ  (LUIy2030)  IANS 


IF  (IANSM;Q»2HA 

) 

GOTO 

100 

IF  (1ANS*EQ<2HB 

) 

GOTO 

200 

IF  (IANSvEQ»2HC 

) 

GOTO 

300 

IF  ( lANSa:.Q<.2HD 

) 

GOTO 

400 

IF  (IANS»EQ.2HE 

) 

GOTO 

500 

IF  (lANS^EQMHF 

) 

GOTO 

600 

IF  (IANS*EQ.2HN0) 

RE  1 URN 

WRITE  (LUTyl200) 

GOTO  51 

EDIT  EXPECTATIONS 

USER  INPin  ">  SUBHEADING  NUMBER 
WRITE  (LUTy3020) 

READ  (LUTy:^0  II 
GOTO  85 

USER  INPUT  ">  LAND  USE  OPTION  REFERENCE  NUMBER 
WRITE  ( CUT y 3030) 

READ  (LUTy>^;)  LUORN 

IF  (LUDRN»6E,lcANr.FLU0RN.LE.6)  GOTO  56 
WRITE  <LUTyl200) 

GOTO  55 
II  II  + L 

USER  INPUT  ->  EXPECTATION  OALUE 
WRITE  ( LOT y 3040) 

READ  (LUTy:^:)  SOCECN  ( II  y LUORN) 

IF  (SOCECN  (II y LUORN ) »GE*0»AND*S0CECN  ( 1 1 y LUORN ) . LE\ 4 ) 
GOTO  700 
WRITE  (LUly3050) 

GOTO  59 


EDIT  RESPONSES 

I OLD  = RSOCEC  (NN) 

WRITE  (LUTy2040)  lOLD 
GOTO  83 

INPUT  RESPONSES 


USER  INPUT  -->  RSOCEC 
WRITE  (LUfy2000) 

READ  iLUJyt)  RSOCEC  (NN) 

IF  (RSOCEC  (NN).EQ.O)  GOTO 
II  = RSOCEC:  (NN) 

IF  ( 1 1 * GE  M . AND  < 1 1 LE  M SOC 
WRITE  (LUTyl200) 

GOTO  (83yS3y57)  MODE 

DISPLAY  HEADING  A -> 

NN  =-  1 
J =-•=  1 
L J“1 

I F ( MODE  ♦ NE  M <•  AND  . LER  ) CALL 
IF ( MODE ♦ NE  M . AND  * LER ) CALL 
WRITE  (LUTylOOO)  (SCEC  (lyl) 
WRITE  (LUT?1020) 


(NN) 

(900y87)  MODE 

(NN))  GOTO  (800y700y54)  MODE 
ARCHAEOLOGIC  SITES 

ERASE 

HOME 

yl  lyl3) 


WRITE  (LUTyl050)  ( (SCEC  (Kyl)yl  l?13)yK  2y4) 
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0167 

0168 

0169 

110 

0170 

111 

0171 

c 

0172 

0173 

0174 

0175 

0176 

0177 

0178 

200 

0179 

0180 
0181 
0182 

205 

0183 

0184 

0185 

0186 

210 

0187 

0188 

215 

0189 

C 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

300 

0197 

0198 

0199 

0200 

305 

0201 

0202 

310 

0203 

C 

0204 

0205 

0206 

0207 

0208 

0209 

0210 

400 

0211 

0212 

0213 

0214 

410 

0215 

0216 

415 

0217 

C 

0218 

0219 

0220 
0221 
O'? 

V*  A. 

500 

DO  110  K 5j6 

WRITE  (LUTyllOO)  (SCEC  = l?13)y  (SOCECR  (Jyl)rl 

J =••  J + 1 

GOTO  (70>60t52)  MODE 

DISPLAY  HEADING  B ~>  PRESENT  LAND  USE 

NN  = 2 

J ISOC  (1)  -f  1 
L = J"1 

IF  (.NOT^LER)  GOTO  205 
CALL  ERASE 
CALL  HOME 


WRITE  (LUTylOOO) 
WRITE  (LUTyl020) 
WRITE  (LUTyl050) 
DO  210  K ==  10?  13 
WRITE  (LUT? 1100) 
J J + 1 
WRITE  (LUT?1050) 
DO  215  K = 15? 16 
WRITE  (LUT?1100) 
J = J T 1 
GOTO  111 

DISPLAY 


(SCEC  (1?I)?I  = 1?13) 

( (SCEC  (K?I)?I  = 1?13)?K  = 7?9) 

(SCEC  (K?I)?1  ==  1j13)?  (SOCECN  (J?I)?I 
(SCEC  (14?I)?I  ~ 1?13) 

(SCEC  (K?I)?I  = l?13)y  (SOCECN  (J?I)?I 
HEADING  C ”>  SECONDARY  LAND  USE 


NN  = 3 

J ISOC  (1)  + ISOC  (2)  + 1 
L = J-1 


IF  (*N0T*LER) 
CALL  ERASE 
CALL  HOME 
WRITE  (LUT?1000) 
WRITE  (LUfyl020) 
WRITE  (LUT? 1050) 
DO  310  K =■•  IB?  23 
WRITE  (LUT?1100) 
J = J + 1 
GOTO  111 

DISPLAY 


GOTO  305 

(SCEC  (1?1)?I  = 1?13) 

(SCEC  (17?1)?I  ==  1?13) 

(SCEC  (K?I)?1  = 1?13>?  (SOCECN  (J?I)?I 
HEADING  D ->  FUTURE  LAND  USE  - OWNER 


NN  = 4 

J = ISOC  (1)  -f  ISOC  (2)  + ISOC  (3)  + 1 
L = J~1 


IF  («NOT»LER)  GOTO  410 
CALL  ERASE 
CALL.  HOME 

WRITE  (LUT?1000)  (SCEC  (1?I)?I  = 1?13) 


WRITE  (LOT? 1020) 

WRITE  (LUT?1050)  ( (SCEC  (K?I)?1  = 1?13)?K  ==  24?26) 


= 1?6) 


“ 1 ? 6 ) 


— 1 ? 6 ) 


= 1?6) 


DO  415  K = 18?22 

WRITE  (LUT?1100)  (SCEC  (K?1)?I  = 1?13>?  (SOCECN  (J?I)?1  = 1?6) 
J - J T-  1 
GOTO  111 

DISPLAY  HEADING  E ->  FUTURE  LAND  USE  - COMMUNITY 

NN  = 5 

J --=  ISOC  (1)  -I-  ISOC  (2)  T ISOC  (3)  4 ISOC  (4)  4 1 
L J-1 

IF  (.NOT.LER)  GOTO  005 
CALL  ERASE 
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0223 

0224 

0225 

0226 

0227 

0228 

0229 

0230 

0231 

0232 

0233 

0234 

0235 

0236 

0237 

0238 

0239 

0240 

0241 

0242 

0243 

0244 

0245 

0246 
024  7 

0248 

0249 

0250 

0251 

0252 

0253 

0254 

0255 

0256 

0257 

0258 

0259 

0260 
0261 
0262 

0263 

0264 

0265 

0266 

0267 

0268 
0269 


1^13) 

= lyl3)yK 


27^29) 


CALL  HOME 

WRITL  (LUTjIOOO)  <SCEC  (lyl)yl  == 

505  WRITE  (LU7j1020) 

WRITE  (LUTjIOSO)  ( (SCEC  (Kyl)yl 
DO  510  K = 18y22 

WRITE  (LOT, 1100)  <SCEC  (K?I)yl  = l?13)j  (SOCECN  (Jyl)yl  = 1j6) 
510  J ==  J -f  1 
GOTO  111 

C DISPLAY  HEADING  I"  ->  FU I ORE  LAND  USE  - GOMERNMENT 

600  NN  = 6 

J = ISOC  (1)  T ISOC  <2)  + ISOC  (3)  T ISOC  (4)  + ISOC  (5)  T 1 
L = J~1 

IF  (.NOT^LER)  GOTO  605 
CALL  ERASE 
CALL  HOME 

WRITE  (LOT?  1000)  (SCEC  (l^Drl  = 

605  WRITE  ( LOT » 1020) 

WRITE  (LUIyl050)  ( (SCEC  (K,I)fI 
DO  610  K = 18>22 

WRITE  (LUTyllOO)  (SCEC  (Kyi)jl  = 1?13)?  (SOCECN  (Jyl)yl  =-•  1?6) 
610  J = J T 1 
GOTO  111 

C USER  INPUT  ->  MORE  EDITS  ? 

700  WRITE  (LUfy3060) 

READ  (LOT? 2030)  IANS 

IF  (IANS.NE.2HYE)  RETURN 
GOTO  1 

C INPUT  MODE  ->  DIRECT  TO  RF<DPER  HEADING 

BOO  IF  (NKUEQ*NSOC)  RETURN 

GOTO  ( 200 7 300 y 400? 500 r 600)  NN 
C USER  WANTS  OUT  ~>  RETURN 

900  RETURN 

C FORMAT  STATEMENTS 

1000  FORMAT  ( 13A2?44  ^ ^ f ) f / y'26Xf  ^ f j 

?<10X?  'STANDARD  EXPECTATIONS '?  1 IX ? r/f 
S26X?44  i-f  ) ?/?26X?  * :^'CROP)^c  ‘ ?2X? 

S"NAi  IOE“  ?2X?  ‘){^:WILD5(c*  ?2X?  'WATER'  ?3X? 

£ • Jl'iHI 6H-4NJTHER^  ' ? / ? 26X  ? 

£'>fcLAMD-^0E6Ef  ATION:f:LIFE)KRECREATION:«USE. 


1?13) 

= 1?13) ?K  = 30?33) 
1?13)?  (SOCECN  (J?1)?I 


C 


1020  FORMAT  (70  ( ' ' ) ? / ? 26X  “ “ 4X  “ ' lOX ' " 4X  “ ^ ' lOX ' )«  ' 4X ' >fc“  5X ' )fc ' ) 

1050  FORMAT  < 1 3A2  ? " ? 4X  ? ' ' ? lOX  ? ' ? 4X  ? “ ' ? 

£10X?  ?4X?  ,5X?  ) 


C 


1100  FORMAT  (13A2f 
'II'  t 


11 


t 


II'  t 


II 


t 'll'  t 


'11 


f ) 


0270  C 

0271  1200  FORMAT  (/"YOU  HAUL  TYPED  IN  AN  ILLEGAL  ANSWER^'? 

0272  £/?  "GIUE  HER  ANOTHER  SHOT  ->  _') 

0273  C 

0274  2000  FORMAT  ('ENTER  THE  APPROPRI AT E ' ? 5X ? 

0275  £44  (“?{=:')?/? 'NUMBER?  OR  ZERO  TO  QUIT  ->  _‘) 

0276  C 

0277  1010  FORMAT  ( 17X' INPUT  RESPONSES/SOCIO-ECONOMICS"//) 

0278  C 
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0279  2010  FORMAT  ( 17X*E:DIT  RESPOMSES/SOCIO-FCOMOMICB V/ ) 

0280  C 

0281  3010  FORMAT  ( 17X“EDIT  EXPECTATIOMS/BDCIO-ECONOMICS " // ) 

0282  C 

0283  2020  FORMAT  (5X“IN  WHICH  HEADING  IS  YOUR  DESIRED  EDIT  TV? 

0284  S5X“  (ENTER  A?D?C?D?E?F?  OR  NONE ) ™>  _V 

0285  C 

0286  2030  FORMAT  (A2) 

0287  C 

0288  2040  FORMAT  (SX'YOUR  CURRENT  RESPONSE  IS  ->V1?//? 

0289  &5X® ENTER  YOUR  NEW  RESPONSE  HERE  ->  „“) 

0290  C 

0291  3020  FORMAT  (5XVN  WHICH  SUD-HEADING  IS  THE  EXPECTATION  VALUE*/? 

0292  &5XV0U  WISH  TO  CHANGE?  (ENIER  THE  APPROPRIATE  NUMBER)  = > „•) 

0293  C 

0294  3030  FORMATI/UX'SELECT  THE  LAND  USE  OPTION  YOU  WISH  TO  CHANGEV 

0295  > IX"  -1-  / -2-  / -3“  / -4-  / ”-5-  / -6-  /"/ 

0296  > 1X"CR0PLAND/NATA)EG  VWILDL1FE/WA7  *REC  VHI6H  USE/  OTHER/" 

0297  >/5X"ENTER  YOUR  SELECTION  HERE  ->  _") 

0298  C 

0299  3040  FORMAT  (5X"ENTER  YOUR  NEW  EXPECTATION  VALUE  HERE  -> 

0300  C 

0301  3050  FORMAT  (/?  5X"ERR0R — > YOUR  EXPECTA7I0N  VALUE  MUST  BE"/? 

0302  %5X"0?1?2?3?  OR  4 TO  AVOID  INTRODUCING  A BIAS  -■>  _") 

0303  C 

0304  3060  FORMAT  <5X"ANY  MORE  EDITS  TO  SOCIO-ECONOMICS  ? (YES  OR  NO)  “ > _') 

0305  C 

0306  END 

0307  END$ 
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SSRCD  T-00004  IS  ON  CR00015  USING  00043  BLKS  R==0000 


0001  FTN4 

0002  SUBROUTINE  SRCD 

0003  C ““-STORE/REfRIEOE  CLAIM  DATA 

0004  C 

0005  C LEOEL  1 

0006  C 

0007  C SRCD  IS  ACCESSED  BY  CLAIM  TO  STORE  AND  RETRIEVE 

0008  C THE  USER'S  DATA  ENTRIES » 

0009  C 

0010  C FILES  ARE  CREATED  SUCH  THAT  THE  CHARACTERS  J AND 

0011  C APPEAR  IN  THE  FIRST  WORD  OF  THE  FILE'S  ID  SEGMENT  FOR  THE 

0012  C GENERAL  DESCRIPTION  PARAMETERS-  ENVIRONMENTAL  DATA  CATEGORIES? 

0013  C AND  THE  ENTIRE  DATA  SET?  RESPECTIVELY*  lOPTN  = 1 MEANS  RETRIEVE? 

0014  C lOPTN  - 2 MEANS  STORE*  IARRY(2)  =••  3 MEANS  1 HAT  WE  ARE  SCHEDULED 

0015  C BY  SEAMPLAN* 

0016  C 

0017  C SRCD  IS  SWAPPED  IN  BY  PF<OGRAM  SRCDX 

0018  C SRCD  USES  THE  TCS  ROUTINES  ERASE  AND  HOME?  AND  CALLS 

0019  C THE  SYSTEM  ROUTINE  SPOLU< 

0020  C THE  LOCAL  VARIABLES  ARE: 

0021  C 

0022  C FILID  - 3 WORD  ID  SEGMENT  OF  THE  FILE  (INTEGER) 

0023  C IANS  “ ANSWER  CELL 

0024  C 

0025  C THIS  RUCniNE  WAS  WRITTEN  BY  GREEN 

0026  C 

0027  C CLAIM  RELEASE  1*0  - APRIL  1?  19800 


TEKTRONIX  COMMON 
COMMON  ITEK  (45) 

LOGICAL  UNITS  AND  COMMON  LOCATION 
COMMON  1ARRY(5) ? IARY2(5) ?LER?LUF?LUL 
POINTERS 

COMMON  EXIT  ? IANM(3) ? ICLl (2) ? IGEN(3) ? IGRW(5) 

COMMON  lOPTN  ? lOVR ( 7 ) ? IPNTR  ? ISOC ( 6 ) ? ISUB ( 8 ) 

COMMON  I SUR ( 6 ) ? I TOP ( 9 ) ? I VEG ( 2 ) ? LEX I T ? LUO 
COMMON  MODE  ?NANH  ?NCLI  ?NGEN  ?NGRW 

COMMON  NOVR  ?NSECTS  ?NSOC  ?NSUB  ?NSUR 

C 0 M M 0 N H T 0 F’  ? N U ? N V E Q 

GRADING  PARAMETERS 

COMMON  AREA(5) ? BENLEN ( 5 ? 1 0 ) ? BENWI (5? 10) ? COGO ? GCPA ( 5 ) 
COMMON  GRDVBS(5) ?HWHT(5? 10) ? HWSL I ( 5 ? 10 ) ? NSPP ( 5 ) ?PCEQ19(4) 
COMMON  PERCNT(5?10) ?REHC}>Y(5) ?REHV0L(5) ?SL0PE(5?10) ? WBP 

CATEGORY  TEXT 


0029  C 

0030  C 

0031  C 

0032 

0033  C 

0034  C 

0035  C 

0036 

0037  C 

0038  C 

0039  C 

0040 

0041 

0042 

0043 

0044 

0045 

0046  C 
004  7 C 

0048  C 

0049 

0050 

0051 

0052  C 

0053  C 

0054  C 
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005b~ 

0056 

0057 
00  5 B 

0059 

0060 
0061 
0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 
0081 
0082 

0083 

0084 

0085 

0086 

0087 

0088 


C 

C 


C 


C 

C 

C 


C 

C 

C 


C 


C 


COHMON  ANIM(23y 13) y CLMA( 13» 13) ? GDES( 15? 13) ?GWHY(22? 13) 
COMMON  OMBD  ( 1 1 ? 1 3 ) ? SBS>L  (13)?  SCEC  ( 33  ? 1 3 ) ? SOH  Y < 4 4 ? 1 3 ) 
COMMON  T8SL ( 49  ? 1 3 ) ? OGT A ( 1 5 ? 1 3 ) 


EXPECTATION  VALUES 


COMMON  ANIMAL< 13?6) ?CLIMAT(8?6) ? GENHES ( 8 ? 6 ) ? GRUHYD < 1 9 ? 6 ) 
COMMON  GVRBUM ( 28  ? 6 ) ? SOCECN ( 29  ? 6 ) ? SUBSOI ( 30  ? 6 ) ? SURH YB ( 23  ? 6 ) 
COMMON  TORSO X ( 33  ? 6 ) ? VEGE'f  A ( 10  ? 6 ) 

CATEGORY  RESPONSES 


COMMON  RANIMA(3) ? RCL IMA < 2 ) ? RGENDE < 3 ) ?RGRWHY(5) 
COMMON  R0VRBD<7? 10) ?RS0CEC(6) ? RSUBSO < 8 ) ? RSURHY ( 6 ) 
COMMON  RTOPSO ( 9 ) ? RVEGET  < 2 ) 

PEASI?TECON?OPUSE  SUBSYSTEM  PARAMETERS 

COMMON  CAAHM?CABAH?CABFN<3)  ? CABF'P ( 3 ) ? CABHM 

COMMON  CABS ( 2 ) ? CAC  ? CACP  ? CADE  ? CADH 

COMMON  CADS  ? CAEAE  ? CAHSAF  ? CAHSTS  ? CAIP 

COMMON  CAR3EC  ? CASE  ? CASNC  ? CSTES  ? CSTRM 

COMMON  CSTRP  ? FAV6 ( 5 ) ? PFSTSP  ? PFAC  ? RCLTEC ( 29  ? 34 ) 

COMMON  TCAR(5) ? THICK (10) ? THKTS ? TTL ( 40 ) 

INTEGER  EX I T ? CLMA  ? GDES  ? 6WHY  ? OUBD ? SBBL 
INTEGER  SCEC  ? SWH Y ? 1 PSL  ? VGTA  ? ANIM 
INT  EGER  CL I MAT  ? GEMDES  ? GRWHYD  ? OVRBDN 
INTEGER  SOCECN? SUBSOI ySURHYD?TOPSOI 
INTEGER  VEGETA?  ANIMAL 

I NTEGER  RCL 1 M A ? RGENDE  ? R6RUH Y ? RO VRBD  ? RSOCEC 
INTEGER  RSLIBSO  yRSURHY?  RTOPSO ?RVEGET?RANIMA 
INTEGER  RCLTEC ?TTL 


0089 


0096  C 


INTEGER  COMMON  (1) 


0090 

EQUIVALENCE 

(COMMON 

(1) 

? ITEK 

0091 

EQUIVALENCE 

(lARRY 

( 1 ) p 

LUT) 

0092 

EQUIVALENCE 

(IARY2 

(1)  ? 

ISTRK) 

0093 

EQUIVALENCE 

(IARY2 

(2)  ? 

ISECT) 

0094 

EQUIVALENCE 

(IARY2 

(3)  ? 

ICODE) 

0095 

EQUIVALENCE 

(IARY2 

( 4 ) ? 

LEN) 

0097  LOGICAL  LER 

0098  C 


0099  INTEGER  FILID  (3) 

0100  DATA  ICR/ 15/ 

0101  C 

0102  C USER  INPUT  ~>  FILE  NAME 

0103  C 

0104  10  IF  (LER)  CALL  ERASE 

0105  IF  (LER)  CALL  HOME 

0106  IF  (lOPTN  .EQ.  2)  WRITE  (LUT?1001) 

0107  IF  (lOPTN  »E0*  1)  WRITE  (LUT?1002) 

0108  GOTO  (12? 14? 16)  IPNTR 

0109  12  FILID  (1)  == 

0110  WRITE(LUT?2001 ) 
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01.1.1 

0112 

0113 

0114 

one; 

0116 

0117 

0118 

0119  C 

0120  C 

0121  C 

0122  C 

0123 

0124 

0125  C 

0126  C 

0127  C 

0128  C 

0129  C 

0130  C 

0131 

0132 

0133 

0134 

0135 

0136 

0137  C 

0138  C 

0139  C 

0140  C 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148  C 

0149  C 

0150  C 

0151  C 

0152 

0153 

0154 

0155 

0156 

0157 

0158  C 

0159  C 

0160  C 

0161  C 

0162 

0163 

0164  C 

0165  C 

0166  C 


GOTO  18 
14  FILI.U  (1)  === 

\4RITE  <LUr?2002) 

GOTO  18 

16  FILID  (1)  2Htt 
ORITE  (Lmr2003) 

18  WRITE  (LUT92004) 

READ  (LUT?  1003)  (FIL.ID  (l)y  I = 2y  3) 

TEST  TO  SEE  .IF  IHIS  FILE  EXISTS 
(LUF  - 6 MEANS  FILE  NON-EXI STENT ) 

CALL  SPGLU  (LUFyFILlljy  2.y  1 y ICR) 

IF  (LUF  *EQ*  “6)  GOTO  (70y  25)  lOPTN 

THE  FILE  HAS  BEEN  SUCCESSFULLY  OPENED.  IF  THE 
USER  IS  STORING  DATA?  MAKE  SURE  THAI  HE  WANTS  TO 
PURGE  THE  EXISTING  DATA  IF  HE  IS  RETRIEOINGy 
BRANCH  our 

IF  (LUE  .LT.  0)  STOP  1 

IF  (lOPTM  eEO.  1)  GOTO  <500y  600?  500)  IPNIR 
READ  (LUEy  1019)  TTL 

WRITE  (LUfy  1005)  (FILID  (J)y  J “ 2y  3)y  TTL 
READ  (LUTy  1004)  IANS 
IF  (IANS  .EQ.  2HYE)  20?  30 

PURGE  THE  EXISTING  FILE  AND  OPEN  A NEW  FILE  FOR  WRITE 
t BRANCH  Oin 

20  CALL  SPOLU  ( LUF ? F ILID ? 2 y 3 ? ICR ) 

IF  (LUF  .LT.  0)  STOP  2 
25  WRITE  (LUI?1042) 

READ  (LUTyi019)  TTL 

CALL  SPOLU  (LUFyFILIDy3?l?lCR) 

IF  (LUF  .LT.  0)  STOP  3 
GOTO  (100?  200?  100)  IPNTR 

CLOSE  EXISTING  FILE  tt  SEE  IF  USER  WANTS  TO 
INPUT  A MEW  FILE  NAME  tt  IF  NOT?  RETURN 

30  CALL  SPOLU  (LUE? FILID? 2? 2? ICR) 

IE  (LUF  tLT.  0)  STOP  4 
WRITE  (LUTyl006) 

35  READ  (LUI?1004)  IANS 

IF  (IANS  .EQ.  2HYE)  GOTO  10 
RETURN 

THE  FILE  DOES  NOT  EXIST  IF  THE  USER  IS  RETRIEVING? 
SEE  IE  HE  WANTS  10  INPUT  A NEW  FILE  NAME 

70  WRITE  (LUT?  1007)  (FILID  (J)?  J 2?  3) 

GOTO  35 

STORE  THE  GENERAL  DESCRIPTION  PARAMETERS 
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0167 

0168 

0169 

0170 

0171 

0172 

0173 

0174 

0175 

0176 

0177 

0178 

0179 

0180 
0181 
0182 

0183 

0184 

0185 

0186 

0187 

0188 

0 1 89 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

0197 

0198 

0199 

0200 
0201 
0202 

0203 

0204 

0205 

0206 

0207 

0208 

0209 

0210 
0211 
0212 

0213 

0214 

0215 

0216 

0217 

0218 

0219 

0220 
0221 
0222 


100 


C 

C 

C 


C 

C 

C 


C 

C 

C 


500 


WRITE 

(LUF- j 

1019) 

TTL 

WRITE 

( I...UF  y 

1020) 

AREA 

WRITE 

( LUF  > 

1021 ) 

BENLEN 

WRITE 

(LUF? 

1021 ) 

BENWI 

WRITE 

(LUF? 

1022) 

COGO 

WRITE 

(LUF? 

1020) 

GCPA 

WRITE 

(LUF? 

1020) 

GRDOBS 

WRITE 

(LUF? 

1021 ) 

HUNT 

WRITE 

(LUF? 

1021  ) 

HWSLI 

WRITE 

(LUF? 

1023) 

NSI-'P 

WRITE 

(LUF? 

1024) 

PCEQ19 

WRITE 

(LUF? 

1021 ) 

PERCNT 

WRITE 

(LUF? 

1020) 

REHCPY 

WRITE 

(LUF? 

1020) 

REHVOL 

WRITE 

(LUF? 

1021 ) 

SLOPE 

WRITE 

(LUF? 

1022) 

WBP 

WRITE 

( LUF  V 

1025) 

RGENDE 

WRITE 

(LUF? 

1022) 

GSTES 

IF  (IF'RTR  <Etn  1) 

450?  210 

STORE 

THE  ENMIRONMENTAL  FEASIBILITY  CAT 

WRITE 

(LUF? 

1019) 

TTL 

WRITE 

(LUF? 

1030) 

RAN IMA 

WRITE 

( LUF  ? 

1031) 

RCLIMA 

WRITE 

(LUF? 

1032) 

RGRWHY 

WRITE 

(LUF? 

3 033 ) 

ROORBD 

WRITE 

(LUF? 

1040) 

NU 

WRITECLUK? 

1041 ) 

T HICK 

WRITE 

( LUF  ? 

1034) 

RSOCEC 

WRITE 

(LUF? 

1035) 

RSUBSO 

WRITE 

( LUF  ? 

1036) 

RSURHY 

WRITE 

(LUF? 

1040) 

RTOPSO  (1) 

WRITE 

(LUF? 

1037) 

(RTOPSO  (D?  1 = 2?! 

WRITE 

(LUF? 

1038) 

RMEGET 

WRITE 

(LUF? 

1022) 

THKT  S 

WRITE 

(LUF? 

1022) 

CSTRH 

WRITE 

(LUF? 

1022) 

CSTRP 

CLOSE 

FILID 

RETURN 

CALL 

8P0LU 

(LUF?FILID?3?2? ICR) 

IF  (LUF  a..T 

. 0)  STOP  6 

RETURN 

RETRIEME  GENERAL 

DESCRIPTION  PARAMETERS 

READ 

( LUF  ? 

1019) 

TTL 

WRITE 

(LUT  ? 

1009) 

(FILID  (J)?  J = 2?  3) 

IF  (LER)  WRITE  (LUTj  1043) 

IF  (LER)  CALL  BELL 

IF  (LER)  CALL  TINPT  (ICHAR) 

READ 

( LUF  ? 

1020) 

AREA 

READ 

(LUF? 

1021  ) 

B E.  N L E N 

READ 

( 1...  UF  ? 

1021  ) 

DENUI 

R E Ai  .U 

( LUF  ? 

1022) 

GOGU 

RtSF-ONSES 


NTOP) 


TTL 
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0223 

READ 

( LUF  y 

1020) 

GCPA 

0224 

READ 

(LUFy 

1020) 

GRDOBS 

0225 

READ 

(LUFy 

1021  ) 

HWI-n 

0226 

READ 

(LUFy 

1021 ) 

HUSLl 

0227 

READ 

(LUFy 

1023) 

NSPP 

0228 

READ 

(LUFy 

1024) 

PCEQ19 

0229 

READ 

( LUF  y 

1021  ) 

PERCNT 

0230 

READ 

( LUF  y 

1020) 

REHCPY 

0231 

READ 

( LUF  y 

1020) 

REHOOL 

0232 

READ 

(LUFy 

1021 ) 

SLOPE 

0233 

READ 

( LUF  y 

1022) 

UBP 

0234 

READ 

(LUFy 

1025) 

RGENDE 

0235 

READ 

( L UF  y 

1022) 

CSTES 

0236 

0237 

IF  (IPNIR 
C 

4EQ*  1) 

750  y 

0238 

0239 

C RETRIEOE  THE  ENOIRONMEN 

C 

0240 

600  READ 

(LUFy 

1019) 

TIL 

0241 

UR  HE 

(LUT 

y 1009) 

(FIL 

02-12 

02-13 

0244 

024^; 

0246 

0247 

0248 

0249 

0250 

0251 

0252 

0253 

0254 

0255 

0256 

0257 

0258 

0259 

0260 
0261 
0262 

0263 

0264 

0265 
02.66 

0267 

0268 

0269 

0270 

0271 

0272 

0273 

0274 

0275 

0276 

0277 
02  78 
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FEASIBILITY  CATEGORY  RESPONSES 


( J) 


2? 


3) 


TTL 


610 


IF  (LER)  ORITE  (LUTy  1043) 
IF  (LER)  CALL  BELL 
IF  (LER)  CALL  TIMPT  (ICHAR) 
READ  (LUFj  1030)  RAN IMA 
1031  .) 

1032) 

1033) 

1040) 

1041) 


READ 

READ 

READ 

READ 

READ 

READ 

READ 

READ 


(LUFy 
( LUF  y 
(LUFt 
(LUF 
(LUF 
(LUF 
(LUFy 
(LUF? 


1034) 

1035) 

1036) 


IF(IARRY(2) .EQ»3) 


RCLIMA 

RGRWHY 

ROMRBD 

NU 

THICK 

RBOCEC 

RSUBSO 

RSURHY 

REAIKLUF  y 1040) 


KDUM 


IF ( I ARR Y ( 2 ) » NE  23 ) READ  ( LUF  y 1 040 ) RTOPSO  ( 1 ) 


61 


READ 

READ 


(LUFy 

(LUFy 


1037) 

1038) 


(RTOPSO 
RMEGE  T 


( 1 ) y I 


NTOP) 


IF  (lARRY  (2) 
IF(IARRY(2) ♦EQ.o 
1F(IARRY(2) .EQ*3) 
IF(IARRY(2) .ME. 3) 
IF( IARRY(2) .NE.3) 
IF(IARRY(2) tNE*3) 


EQ*  3)  READ (LUFy 1022)  BUM 


^) 


READ (LUFy 1022)  DUM 
READ(LUFy 1022)  DUM 
READ  (LUFy  1022)  THKTS 
READ  (LUFy  1022)  CSIRM 
READ  (LUFy  1022)  CSTRP 


C 

C 

C 


750 


C 


2001 

2002 

2003 


CLOSE  THE  FILE  tt  RETURN 

CALL  SPOLU  (LUF yFILIDy2y2y ICR) 

IF  (LUF  .L\\  0)  Slop  7 
RETURN 

FORMAT  STATEMENTS 

FORMAT ( 5X “ GENERAL  DESCRIPT  ION"/ 

5X" ‘■///) 

FORMAT ( 5X " ENOIRONMENl AL  DATA " / 

, 5X" "///) 

FORMAT (5X“ GENERAL  DESCRIPTION  AND  ENMI RONMENTAL  DATA"/ 


C 
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0279 

2004 

FORMAT < 

SX'IMPUT  THE  FILE  NAME  -> 

) 

0280 

C 

0281 

1001 

r* 

FORMAT 

(5X'DATA  STORAGE  M 

02B3 

L 

1002 

FORMAT 

(5X“DATA  RETRIEVAL  “) 

0284 

C 

0285 

1003 

FORMAT 

(2A2) 

0286 

C 

0287 

1004 

FORMAT 

<A2) 

0288 

C 

0289 

1005 

FORMAT 

(5X“THE  FILE  ?‘2A2“  ALREADY 

EXISTS* 

0290 

• 5X*  TITLE  40A2// 

0291 

■ 5X“D0 

YOU  WANT  TO  WRITE  OVER  THIS 

FILE  ? 

0292 

c 

0293 

1006 

FORMAT 

(5X"D0  YOU  WANT  TO  INPUT  A NEW  FILE 

0294 

C 

0295 

1007 

FORMAT 

(5X“THE  FILE  •2A2'  DOES  NOT 

EXIST* 

0296 

• 5X*T0 

INPUT  A NEW  FILE  NAME  ? _") 

0297 

c 

0298 

1.009 

FORMAT 

(SX'NOW  RETRIEVING  DATA  FROM 

FILE  " 

0299 

• 5X“  TITLE  ~>‘'40A2) 

0300 

c 

0301 

1019 

FORMAT 

<40A2) 

0302 

C 

0303 

1020 

FORMAT 

(IX?  5F13*4) 

0304 

C 

0305 

1021 

FORMAT 

(9  (lXf5F13*4?/)ylXy  5F13.4) 

0306 

C 

0307 

1022 

FORMAT- 

(lXyF13.4) 

0308 

C 

0309 

1023 

FORMAT 

(IX?  514) 

0310 

C 

0311 

1024 

FORMAT- 

(IX?  4Fi3.4) 

0312 

C 

0313 

1025 

FORMAT 

(IX?  314) 

0314 

C 

0315 

C 

0316 

1030 

FORMAT 

(IX?  314) 

0317 

C 

0318 

1031 

FORMAT 

(IX?  214) 

0319 

C 

0320 

1032 

FORMAT 

(IX?  514) 

0321 

C 

0322 

1033 

FORMAT 

(9( 1X?7I4?/) ? 1X?7I4) 

0323 

C 

0324 

1034 

FORMAT 

(IX?  614) 

0325 

C 

0326 

1035 

FORMAT 

(IX?  814) 

0327 

C 

0328 

1036 

FORMAT 

(IX?  614) 

0329 

C 

0330 

1037 

FORMAT 

(IX?  814) 

0331 

C 

0332 

1038 

FORMAT- 

(IX?  214) 

0 3 3 3 

C 

0334 

1040 

FORMAT 

(IX?  14) 
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0335  C 

0336  1041  FORHAT  (IXy  1 3 . 4 ? / ? 5F 1 3 ♦ 4 ) 

0337  C 

0338  1042  FORMAT  (5X“  INPUT  TITLE  ”>  _« - ) 

0339  C 

0340  1043  FORMAT  (5X*HIT  THE  REIURN  KEY  TO  CONTINUE 

0341  C 

0342  END 

0343  END$ 
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SBUBSO  T=00004  IS  ON  CR00015  USING  00051  BLKS  k‘=0000 


0001  FTN4 

0002  SUBROUTINE  SUBSO 

0003  C FULL  DISPLAY—CATLOOFsY  4 / SUBSOIL 

0004  C 

0005  C LEVEL  2 

0006  0 


0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 


C SUBSO  IS  ACCESSED  BY  EIED  TO  SCHEDULE  INPUTS  AND  EDITS 
C CATEGORY  RESPONSES?  AND  EDITS  TO  EXPECTATION  Ol-  SUCCESS 
C VALUES  FOR  CATEGORY  4 - SUBSOIL?  USING  FULL  DISPLAY 
C 

C THE  CALLING  SEQUENCE  IS  I CALL  SUBSO 

C 

C SUBSO  USES  THE  TCS  ROUTINE  t ERASE  AND  HOME 
C 

C THE  LOCAL  VARIABLES  ARE  I 
C 

C CHNG 

C IANS 

C II 

C I OLD 

C LUORN 

C 
C 
C 
C 
C 
C 

C NN 

C 

C SUBSO  IS  SWAPPED  IN  BY  PROGRAM  SUBSX 
C 

C THIS  ROUTINE  WAS  WRITTEN 'bY  GREEN 
C 

C CLAIM  RELEASE  1*0  - APRIL  1?  1980 

C 


->  ARRAY  CONTAINING  HEADING  LETTER  CHANGES 
->  ANSWER  CELL 

">  ‘I**  INDEX  C (I?J)  3 TO  SLIBSOl  ARRAY 
">  PRE-EDIT  CATEGORY  RESPONSE  VALUE 
->  LAND  USE  OPTION  REFERENCE  NUMBER 

1- >  CROPLAND 

2- >  NATIVE  VEGETATION 

3- >  WILDLIFE 

4- >  WATER  RECREATION 

5- >  HIGH  USE 

6- >  OTHER 
->  HEADING  NUMBER 


0037  C TEKTRONIX  COMMON 

0038  C 

0039  COMMON  ITEK  (45) 

0040  C 

0041  C LOGICAL  UNITS  AND  COMMON  LOCATION 

004  2 C 

0043  COMMON  IARRY(5) ? IARY2(5) ?LER?LUF  ?LUL 

0044  C 

0045  C POINTERS 

0046  C 

0047  COMMON  EXIT  ? I ANM  ( 3 ) ? I CLK 2 ) ? 1 GEN  ( 3 ) ? 1 6RW  ( 5 ) 

0048  COMMON  lOPTN  ? lOVR ( 7 ) ? IPNTR  ? ISOC ( 6 ) ? I SUB < 8 ) 

0049  COMMON  ISUR(6) ? 1T0P(9) ? IVE6(2) jLEXIT  ?LU0 

0050  COMMON  MODE  ?NANM  ?NCLI  ?NGEN  yNGRW 

0051  COMMON  NDVR  yNSECTS  ? NSOC  yNSUB  ?NSUR 

0052  COMMON  NTOp  j NU  yNVEG 

0053  C 

0054  C GRADING  PARAMEIERS 
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0055 

0056 

0057 

0058 

0059 

0060 
0061 
0062 
0063 
006'-1 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 
0081 
0082 

0083 

0084 

0085 

0086 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 
0101 
0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


C 


C 

c 

c 


t: 

8 

c: 


c 

c 

c 


c 


t: 

c 


c 


c 


c 

c 

c 

C: 

f' 


COMMON  AF<E A ( 5 ) y 8F- NLEN  ( 5 y 1 0 ) y 8F1 NW I ( 5 y 1 0 ) y C060  y GCPA  < 5 ) 
COMMON  GRDO.BS  < 5 ) y FINFI  F < 5 y 1 0 ) y F1WSL I ( 5 y 1 0 ) y NSF’P  < 5 ) y PCEO 1 9 < 4 ) 
COMMON  PEfs'CNKSy  10)  yF-:EHCPY(5)  y REFIOOL  < 5 ) y BLuPE  ( 5 y 10 ) y WPP 

CATEGORY  fEXT 

^COMMON  AM I M ( 23  y 1 3 ) y CLMA ( 1 3 y 1 3 ) y GUES  < 1 5 y 1 3 ) y GWH Y ( 22  y 1 3 ) 
COMMON  OOBD  < 1 1 y 1 3 ) y 8PSL ( 1 3 ) y SCEC ( 33  y 1 3 ) y SWH  Y ( 4 4 y 1 3 ) 
COMMON  TPGL(49y 13) y VGTA( 15y 13) 


EXPECTATION  0 ALOES 

COMMON  ANIMAL ( 13  y 6 ) ? CL IMA  I ( 8 y 6 ) y GENDES ( 8 y 6 ) y GRWHYD ( 1 9 y 6 ) 
COMMON  OMRBDN ( 28  y 6 ) y 80CECN ( 29  y 6 ) y SUBSOI ( 30  y 6 ) y SURH YD ( 23  y 6 ) 
COMMON  TOPBOI (33y6) y OEGET A < 1 0 y 6 ) 


CATEGORY  RESPONSES 

COMMON  RAN I MA ( 3 ) y RCL I MA  < 2 ) y RGENDE  < 3 ) y RGROH Y ( 5 ) 


COMMON  ROMRBD  < 7 y 1 0 ) y RSOCEC  ( 6 ) y RSUBSO  < 8 ) y RSURF-i Y ( 6 ) 


COMMON  RT0PS0(9) yROEGE  f (2) 


F-EASI  y TECONyOPUSE  SUBSYSTEM  PARAMETERS 


COMMON  CAAHM  y CABAN  y CADF" N < 3 ) y CABFP  ( 3 ) y CAHBM 

COMMON  CABS  < 2 ) y CAC  y CACP  y CADF  y CADH 

COMMON  CADS  y CAEAF  y CANS AF  y CAHSTS  y CA I P 

COMMON  CAR3FC  y CASF  y CASNC  y CSTEB  y CSTRM 

COMMON  CSIRP y FAOG  < 5 ) y PFSTSP  y PFAC  y RCLTEC ( 29  y 34 ) 

COMMON  TCAR ( 5 ) y THICK  < 1 0 ) y THKTS  y TTL  < 40 ) 

INTEGER  EX I T y CLMA  y GDES  y GWHY  y OUBD  y SBBL 
INTEGER  BCECy BOHYy  TPSLyOGTAy ANIM 
1 NTE6ER  CL I HAT  y GENDES  r GRWH YD  y OORBDN 
INTEGER  SOCECNy  SUBSOI y SURHYD y TOPSOl 
I N T E G e:  R 0 E G E T a y a N I M a L 

INF  EGER  RCL I MA  y RGENDE  y RGRWHY  y ROURBD  y RSOCEC 
IN  F EGER  RSUBSO ? RSURHY  y R I OPSO  y ROEGE  F y RAN IMA 
INTEGER  RCLFECyTTL 


INTEGER  COMMON  <1) 
EQUIOALENCE  (COMMON  (1) 
EQUIOALENCE  ( lARRY  ( 1 ) y 
EQUIVALENCE  (IARY2  (l)y 
EQUIVALENCE  (IARY2  <2)y 
EQUIVALENCE  (IARY2  (3)y 
EQUIVALENCE  (IARY2  (4)y 


y ITEK  (D) 
LUF  ) 

ISTRK) 

ISECT) 

I CODE) 

LEN) 


LOGICAL  LER 
INTEGER  CHN6  (7) 


DATA  CHN6/2H  By2F-i  Cy2H  Dy2H  Ey2H  Fy2H  6y2H  H/ 


DISPLAY  MODE  I 


232 


0111 


IF  (♦N0T*LER)  GOTCI 


0112 

CALL 

ERASE 

0113 

CALL 

HOME 

0114 

5 

GOTO 

(10y20y30)  MODE 

0115 

10 

WRITE 

(LUTy 1010) 

0116 

GOTO 

40 

0117 

20 

WRITE 

(LUI y2010) 

0118 

GOTO 

40 

0119 

30 

WRITE 

(LUTy 3010) 

0120 

40 

IF 

( MODE»GT<.  1 ) 

GOTO  50 

0121 

GOTO 

(100?  200  y 250  y 300  y 350  y 400 

0122  C 

USER  INPUT 

”>  EDIT  Hi 

0123 

50 

WRITE 

(LUTy 2020) 

0124 

51 

READ 

(LUTy 2030)  IANS 

0125 

IF 

(IANS*ECU2HA  ) 

GOTO  100 

0126 

IF 

( IANS.EQ.2HB  ) 

GOTO  200 

0127 

IF 

(IANS4EQ*2HC  ) 

GOTO  250 

0128 

IF 

(1ANS.EQ.2HD  ) 

GOTO  300 

0129 

IF 

(1ANS.EQ*2HE  ) 

GOTO  350 

0130 

IF 

(IANS.EQ<.2HF  ) 

GOTO  400 

0131 

IF 

(IANS*EQ*2h'G  ) 

GOTO  450 

0132 

IF 

(IANS.EQ.2HH  ) 

GOlO  500 

0133 

IF 

(IANS»£Q.2HN0) 

RETURN 

0134 

WRITE 

(LUTy 1200) 

013b 

0136 

0137 


C 


LEXIT 


HEADING 


GOTO  51 


DISF'LAY  HEADING  A 


THICKNESS 


100  NN 


0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 


= 0 
J = 1 

IF  < NODE  <-  NE  < 1 < AND  LER ) CALL  ERASE 
IF( NODE ♦ NE* 1 * AND  a.ER)  CALL  HOME 
WRITE  (LOT? 1000)  (SDSL  (I)y  I = 1?13) 
WRITE  (LUTyl020) 

WRITE  (LUTylOSO)  (TPSL  <2yl)yl  ==  1?13) 
DO  101  K = 3j6 


0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 
0161 
0162 

0163 

0164 

0165 

0166 


WRITE  (LUTyllOO)  (TPSL  (Kyl)yl  = lyl3)y  (SUBSOI  (jyl)yl 

101  J = J + 1 

GOTO  (140y 135yll0)  MODE 
C EDIT  EXPECTATIONS 

C USER  INPUT  “>  SUBHEADING  NUMBER 

110  WRITE  <LUTy3020) 

111  READ  (LUTy:<<)  II 
GOTO  145 

C USER  INPUT  ->  LAND  USE  OPTION  REFERENCE  NUMBER 

115  WRITE  (LUT?3030) 

116  READ  LUORN 

IF  (LUORf-nGEM  ♦ AND*LUORN.LE<  6)  GOTO  120 
WRITE  <LUTyl200) 

GOTO  115 

120  II  = II  + L 

130  WRITE  (LUTy3040) 

131  READ  (LUTyY)  SUBSOI  ( II y LUORN) 

I F ( SUBSOI  (11, LUORN ) ♦ GE ♦ 0 * AND . SUBSOI  ( 1 1 y LUORN ) . LE  ^ 4 ) 

-}■  GOTO  600 
WRITE  (LUTy 3050) 

GOTO  131 


1 y6) 
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E.DJ.T  RESPONSES 


0167 

0168 

0169 

0170 

0171 

0172 

0173 

0174 
0170 

0176 

0177 

0178 

0179 

0180 
0181 
0182 

0183 

0184 
0180 
0106 

0187 

0188 

0189 

0190 

0191 

0192 

0193 

0194 
0190 

0196 

0197 

0198 

0199 

0200 
0201 
0202 

0203 

0204 
0200 
0206 

0207 

0208 

0209 

0210 
0211 


130  lOLlj  RSU8S0  (NN) 

136  WRITE  (LUIy2040)  IGLU 
GOTO  144 

C INPUT  RESPONSES 

C USER  INPUT  ->  RSUBSO  (NN) 

140  WRITE  (LUf?2000) 

144  READ  (LUTy'^:>  RSUDSO  <NN) 

IF  (RSUDSO  (NN).EQ.O)  GOTO  (900^146)  NODE 
II  RSUDSO  (NN) 

145  IF  (II»GE,l*ANrull<-LE<.lSUB  (NN)) 

T GOTO  ( 700  f 600  y 1 1 5 ) MODE 

146  WRITE  (LUTylSOO) 

147  GOTO  (144yl44y 110)  MODE 

C DISPLAY  HEADING  B ~>  TEXTURE 

200  NN  2 

J ISUB  (1)  -}■  1 

L ---  J-1 

IF  (.NOT.LER)  GOTO  205 
CALL  ERASE 
CALL  HOME 

WRIIE  (LUIyiOOO)  (SDSL  (I)yl  1j13) 

205  WRITE  (LUfyl020) 

WRITE  (LUlyl051)  CHN6  (l)y  (TPSL  (12yl)yl  == 
DO  210  K = 13ylB 

WRITE  (LUlyllOO)  (TPSL  (Kyl)yl  ~ lyl3)y 


2 y 1 3 ) 

(SUBSOI  ( Jy I ) y I 


1 y6) 


210  J 


J 


1 


G0T0(140y 1356110)  MODE 

C DISPLAY  HEADING  C ->  STRUCTURE 

250  NN  ==  3 

J =:  ISUB  (1)  T ISUB  (2)  T 1 
L = J-1 

IF  (♦N016LER)  GOTO  255 
CALL  ERASE 
CALL  HOME 

254  WRITE  (LUfylOOO)  (SDSL  (l)yl  = lyl3) 

255  WRITE  (LUTyl020) 

WRITE  (LUTylOSl)  CHN6  (2)y  (TPSL  (19yl)yl 
WRITE  (LUTyl050)  (TPSL  (20yl)yl  = lyl3) 


13) 


DO  260  K 


21 


WRITE  (LUTyllOO) 
260  J ==  J -}-  1 


(TPSL  (Kyl)yl 


lyl3)y  (SUBSOI  (Jyl)yl 


1 y 6 ) 


G0T0(140y 135y 110)  MODE 
C DISPLAY  HEADING  D 

300  NN 


BULK  DENSITY 


4 


0212 

J ISUB  (1)  T 1 

SUB  (2)  T ISUB 

(3)  T 

1 

0213 

L ==  J-1 

0214 

IF  ( *N016LER) 

GOTO  305 

0215 

CALL  ERASE 

0216 

CALL  HOME 

0217 

WRITE  (LmylOOO) 

(SBSL  (I)yl  = 

1 y 13) 

0218 

305  WRITE  ( LOT y 1020) 

0219 

WRITE  (LU  fy 1051 ) 

CHNG  (3)  y (TPSL  (2 

4?  I ) 

0220 

WRITE  (LUTylOSO) 

(TPSL  (25? I) 

y I = 1 

y 1 3 ) 

A*  - 

DO  310  K 26?  27 

A— 

WRITE  (LUT?ilOO) 

(TPSL  (K?I)y 

1 ^ 1 y 

1 S ) ? 

2 y 1 3 ) 


(SUBSOI  (Jyi)?l  " iy6> 
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0223 

022-1 

0225 

0226 

0227 

0228 

0229 

0230 

0231 

0232 

0233 

0234 

0235 

0236 

0237 

0238 

0239 

0240 

0241 

0242 

0243 

0244 

0245 

0246 

0247 

0248 

0249 

0250 

0251 

0252 

0253 

0254 

0255 

0256 

0257 

0258 

0259 

0260 
0261 
0262 

0263 

0264 

0265 

0266 

0267 

0268 

0269 

0270 

0271 

0272 

0273 
0 2 7 4 

0275 

0276 

0277 

0278 


SALINITY 


y 13) 


<TPSL  (K?l)yl  lyl3)y  (SUBBOl  <JyI)?I 


310  J ==  J f 1 

80T0< 140? 135y 110)  NODE 
C DISPLAY  HEADING  E 

350  NN  ==  5 

J =-•  ISUB  (1)  i ISUB  (2)  -}•  ISUB  (3)  i ISUB  (4)  -f  1 
L J“1 

IF  (♦NOT^LER)  GOTO  355. 

CALL  ERASE 
CALL  HOHE 

L'RITE  (LOT?  1000)  (SBSL  (1)?I  = 1?13) 

355  WRITE  (LOT? 1020) 

WRIIE  (LOT?  1051)  CHN6  (4)?  (TPSL  (28?1)?I  - 
If 0 3 6 0 K “ 2 9 ? 3 3 
WRITE  (LOT? 1100) 

360  J ==  J T 1 

GOTO (140? 135? 110)  NODE 

C DISPLAY  HEADING  F “•>  SODIUM  ADSORPTION  RATIO 

400  NN  ==  6 

J =:=  ISUB  (1)  T ISUB  (2)  T ISUB  (3)  T ISUB  (4)  T ISUB  (5)  T 
L ==  J“-l 

IF  (.NOT.LER)  GOTO  405 
CALL  ERASE 
CALL  HOME 

404  WRITE  (LUT?1000)  (SBSL  (I)?I  = 1?13) 

405  WRITE  (LUT?1020) 

WRITE  (LUT?i051)  CHNG  (5)?  (TPSL  (34?I)?I  2?13) 

WRITE  (LUT?1050)  (TPSL  (35?I)?I  ==  1?13) 

DO  410  K = 36? 39 

WRITE  (LUT?1100)  (TPSL  (K?1)?I  = 1?13)?  (SUBSOI  (J?I)?1 
410  J = J i 1 

GOTO (140? 135? 110)  MODE 

C DISPLAY  HEADING  G ->  NITROGEN 

450  NN  = 7 

J = ISUB  (1)  T ISUB  (2)  T ISUB  (3)  + ISUB  (4)  + ISUB  (5)  T 
T ISUB  (6)  T 1 
L = J-1 

IF  (.NOT^LER)  GOTO  455 
CALL  ERASE 
CALL  HOME 

WRITE  (LUT?1000)  (SBSL  (1)?I  = 1?13) 

455  WRITE  (LUT?1020) 

WRITE  (LUT?1051)  CHNG  (6)?  (TPSL  (40?I)?I  = 2?13) 

WRITE  (LUT?1050)  (TPSL  (41?I)?I  = 1?13) 

DO  460  K 42?  44 

WRITE  (LUT?1100)  (TPSL  (K?I)?I  = 1?13)?  (SUBSOI  (J?I)?I 
460  J = J T 1 

G0T0(140?135?110)  MODE 

C DISPLAY  HEADING  H ->  PHOSPHORUS 

500  NN  ==  8 

J ==  ISUB  (1)  T ISUB  (2)  T ISUB  (3)  + ISUB  (4)  T ISUB  (5)  T 
T ISUB  (6)  + ISUB  (7)  T 1 

L = J-1 

IF  (♦NOT^LER)  GOTO  505 
CALL  ERASE 
CALL  home 

WRIVE  <LUT?1000)  (SDSL  (1)?I  ==  1?13) 


~ 1 ? 6> ) 


1 


= 1?6) 


1 ? 6 ) 
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c 

c 


c 

c 


c 

c 

c 


c 

c 

c 


027? 
0280 
0281 
0282 

0283 

0284 

0285 

0286 
0287 
02BS 

0289 

0290 

0291 
02;  2 

0293 

0294 

0295 

0296 

0297 

0298 

0299 

0300 

0301 

0302 

0303 

0304 

0305 

0306 

0307 
308 

. 309 
./310 

0311 

0312 

0313 

0314 

0315 

0316 

0317 

0318 

0319 

0320  C 

V O 1 
O J. 

0322 

0323 

0324 

0325 

0326 

0327 

0328 

0329 

0330 

0331 

0332 


0333 


505  UR.TTL"  <LU}3  1020) 

WRITH:  (L(JT>-1051)  CHNG  <7)y  (TRSL  (45yI)»I  = 2»13) 

WRllR  <LUTyi050)  <TPSL  (46^1) yX  = lyl3) 

DO  510  K ==  47j49 

URXTL"  (LUTyllOO)  (TPSL  (Kyl)?l  = lyl3)y  (SUBSOI  (Jyl)yl 
510  J J -}■  1 

G0T0(140y 135yll0)  MODE 

USER  INPUT  “>  MORE  EDITS  ? 

600  URIIE  (LUTy3060) 

READ  < LUT  y 2030 ) I ANS 

IF  <IANS.NE<.2HYE)  RETURN 
GOTO  1 

INPUT  MODE  ">  DIRECT  TO  PROPER  HEADING 

700  IF  (NN.EQoNSUB)  RETURN 

GOTO  ( 200 y 250 y 300 y 350 y 400? 450^500)  NN 

USER  HANTS  OUT  ->  SET  EXIT  TO  ZERO  AND  RETURN 

900  EXIT  =:  0 
RETURN 


FORMAT  STATEMENTS 


C 


C 


C 


1000  FORMAT  < 13A2y44  ( * « “ ) y / ? 26X  ? " )« " p 

SlOX?  '^STANDARD  EXPECTATIONS*  ? IIX? 

^26X?44  y/?26Xy  “ ^CROP)fc  * ?2Xy 

SANATIVE'  ?2Xp  “>^UILD5^2'  y2X?  'WATER*  ?3Xp 
^ GIU-OTHER^i ' ? / ? 26X  y 

5^":^fLAND)JcVEG£ TATI0N)^:L1FE:^RECREATI0N^USE  " y 5X ? “ )j=: ‘ ) 

1020  FORMAT  <70  < * ^:  * ) y / y 26X  ? " “ 4X  * lOX  “ “ 4X ' « “ lOX  * ^ * 4X  " ^ 5X  “ « * ) 

1025  FORMAT  ( "ACTUAL  THICKNESS  UP  SUBSOIL  (FEET)  ->  _") 

1050  FORMAT  ( 13A2 y " ^ " y 4X  y ‘ » , iOX  y " " y 4X  ? " “ y 
SIOXp  y 4X?  p5Xp  •‘f  ) 


C 


1100  FORMAT  (13A2y 
“II"  t 


11 


t 


11"  t 


II  • 


t "II 


t 


II 


1200  FORMAT  (/"YOU  HAME  TYPED  IN  AN  ILLEGAL  ANSWER. "y 


li/y  "GI'v'E  HER  ANOTHER  SHOT 


) 


C 


c: 


C 


C 


c 


0334 


1051  FORMAT  (A2y  12A2?  "9^;"  y4X?  “ ? lOX?  " " y4X?  " " y 

SlOXy  y4Xy  ?5Xy  ) 

2000  FORMAT  ("ENTER  THE  APPROPRIATE "? 5Xy 

&44  ( ">1^"  ) y/y  "NUMBERy  OR  ZERO  TO  QUIT  ->  _") 

1010  FORMAT  ( 17X" INPUT  RESPONSES/SUBSUIL " // ) 

2010  FORMAT  ( 17X"EDIT  REGPONSES/SUDSOIL * // ) 

3010  FORMAT  ( 17X‘'EDjT  EXPECTATIONS/SUBSOIL"//) 


1 y 6 ) 
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0336 

0337 

0338 

0339 
03^10 

0341 

0342 

0343 
034  4 

0345 

0346 

0347 

0348 

0349 

0350 

0351 

0352 

0353 

0354 

0355 

0356 

0357 

0358 

0359 

0360 

0361 

0362 


C 


C 


C 


C 


C 


C 


C 


C 

c 

C: 


2020  FORMAT  (5X-IN  WHICH  HEADING  IS  YOUR  DESIRED  EDIT  TV? 

&5X'  (ETFlER  A?D?C?DyE?FyG?H?  OR  NONE)  ->  _“) 

2030  FORMAT  (A2) 

2040  FORMAT  (5X‘^Y0UR  CURRENI  RESPONSE  IS  -“>V2?// 

SOX-ENTER  YOUR  NEW  RESPONSE  HERE  ->  _“) 

3020  FORMAT  (5X‘IN  WHICH  SUD-HEADING  IS  THE  EXPECTAIION  VALUE  V 
g5X"Y0U  WISH  TO  CHANGE  ? (ENTER  THE  APPROPRIATE  NUMBER)~> 

3030  F0RMAT(/5X"SELECT  THE  LAND  USE  OPTION  YOU  WISH  TO  CHANGE**/ 

> 1X“  "i~  / “2“  / "3“  / -4-  / -5--  / “6~  /V 

> 1X“CR0PLAND/NAI  *OEGVWILDLIFE/WAI  *REC«-/HIGH  USE/  OTHER/** 
X/UX^ENTER  YOUR  SELECTION  HERE  ->  _V 

3040  FORMAT  (5XV;NIER  YOUR  NEW  EXPECTATION  VALUE  HERE  ->  V 

3050  FORMAT  </?  5X“ ERROR — > YOUR  EXPECTATION  VALUE  MUST  BE“/? 
%5X**0y  1 j2?3?  OR  4 TO  AVOID  INTRODUCING  A BIAS  ->  _“) 

3060  FORMAT  (5X'ANY  MORE  EDITS  TO  SUBSOIL  ? (YES  OR  N0)->  _") 


END'$ 


&SURHY 


T--::00004  is  on  CROOOiS  USING  00047  BLKS  R = 0000 


0001  FTN4 

0002  SUBROUT I ME  SURH Y 

0003  C FULL  DISPLAY — CATEGORY  6 SURFACE  UAIER  HYDROLOGY 

0004  C 

0005  C LEOEL  2 

0006  C 


0007  C SURHY  IS  ACCESSED  BY  EIFD  TO  SCHEDULE  INPUTS  AND  EDITS 

0008  C CATEGORY  RESPONBESj  AND  EDITS  TO  EXPECTATION  OF  SUCCESS 

0009  C VALUES  FOR  CATEGORY  6 ~ SURFACE  WATER  HYDROLOGY?  USING 

0010  C FULL  DISPLAY* 

0011  C 

001 2 C THE  CALLING  SEQUENCE  IS  t CALL  SURHY 

0013  C 


0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 


C 

C 

C 

C 

c 

c 

c 

c 

c 

c 

c 


c 

c 

c 

c 

c 

c 

c 


SURHY  USES  THE  TCS  ROUTINES  t ERASE  AND  HOME 
THE  LOCAL  VARIABLES  AREJ 


IANS  -> 

ANSWER 

CELL 

II  “> 

“I*  INDEX  i (I?J)  3 TO  SURHYD  ARRAY 

I OLD  "> 

PRE-EDIT  CATEGORY  RESPONSE  VALUE 

LUORN  ~> 

LAND  USE  OPTION  REFERENCE  NUMBER 

1"> 

CROPLAND 

NATIVE  VEGETATION 

3“> 

WILDLIFE 

4 “ > 

WATER  RECREATION 

5“  > 

HIGH  USE 

6~> 

OTHER 

NN 

HEADING 

NUMBER 

URHY  IS  SWAP 

■PED  IN 

BY  PROGRAM  SURHX 

C THIS  ROUTINE  WAS  WRITIEN  BY  GREEN 
C 


0034  C CLAIM  RELEASE  1*0  - APRIL  1?  1980 

0036  C 


0037  C TEKTRONIX  COMMON 

0038  C 

0039  COMMON  ITEK  (45) 

0040  C 

0041  C LOGICAL  UNITS  AND  COMMON  LOCATION 

0042  C 

0043  COMMON  IARRY<5) ?IARY2<5) ?LER?LUF?LUL 

0044  C 

0045  C POINTERS 

0046  C 

004 7 COMMON  EX IT  ? I ANM ( 3 ) ? I CL I < 2 ) ? I GEN ( 3 ) ? 1 6R W ( 5 ) 

0048  COMMON  lOPTN  ? I0VR(7) ?IPNTR  ? ISGC<6) ?1SUB(8) 

0049  COMMON  ISUR ( 6 ) ? I TOP ( 9 ) ? I VEG ( 2 ) ? LEXIT  ? LUO 

0050  COMMON  MODE  ? NANH  ?NCLI  ?NGEN  ?NGRW 

0051  COMMON  NOVR  ?NSECTS  ? NSOC  ?NSUB  ?NSUR 

0052  COMMON  NTOP  ?NU  ? NVE'G 

0053  C 

0054  C GRADING  PARAMETERS 
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005ti  C 


0056 

005/ 

0058 

0059  C 

0060  C 

0061  C 

0062 

0063 

0064 

0065  C 

0066  C 

0067  C 

0068 

0069 

0070 

0071  C 

0072  C 

0073  C 

0074 

0075 

0076 

0077  C 

0078  C 

0079  C 

0080 
0081 
0082 
00B3 

0084 

0085 

0086  C 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094 

0095  C 


COMMON  AREA<5) ? BEMLEN < 5 ? 1 0 ) y BENWI ( 5 y 10 ) ? C060 y 6CPA ( 5 ) 
COMMON  GRDUBS  ( 5 ) ? HWHT  ( 5 y 1 0 ) ? EIWSL  i(  5 y 1 0 ) y NSPP  ( 5 ) y PCEQ 1 9 < 4 ) 
COMMON  PERCNT(5y 10) y REHCPY(5) y REHOOL ( 5 ) y SLOPE ( 5 y 10 ) y WBP 


CATEGORY  TEXT 

common  an I M < 23  y 1 3 ) p CLMA (1 3 ? 1 3 ) y ODES (1 5 y 1 3 ) ? 6WH  Y ( 22  ? 1 3 ) 
COMMON  OOBD ( 1 1 p 1 3 ) y SBSL ( 1 3 ) p SCEC ( 33  y 1 3 ) y 6 WH Y < 4 4 y 1 3 ) 
COMMON  TPSL(49p 13) yOGTA( 15y 13) 

EXPECTATION  VALUES 


COMMON  AN  I MAL  ( 1 3 y 6 ) ? CL  I M AT  ( 8 y 6 ) y GENDES  < 8 y 6 ) y GRkM-i  YB  ( 1 9 y 6 ) 
COMMON  OVRBDN ( 28  y 6 ) y SOCECN  < 29  y 6 ) y SUBSOI ( 30  y 6 ) y SURHYB ( 23  y 6 ) 
COMMON  TOPSOI ( 33  y 6 ) y VEGETA ( 10  ? 6 ) 

CATEGORY  RESPONSES 

COMMON  RANIMA(3) yRCLlMA<2) y RGENDE < 3 ) y R6RWHY ( 5 ) 

COMMON  ROVRBD ( 7 ? 1 0 ) y RSOCEC ( 6 ) y RSUBSO  < 8 ) y RSURH Y < 6 ) 

COMMON  RTOPSO ( 9 ) y RVEGET  < 2 ) 

FEASI y TECON  p OPUSE  SUBSYSTEM  PARAMETERS 

COMMON  CAAHM  y CABAH  ? CABFN ( 3 ) ? C ABFP ( 3 ) y C AHBH 

COMMON  CABS ( 2 ) y CAC  y CACP  y CADF  y CADH 

COMMON  CABS  y CAEAF  y CAHSAF  y CAHSTS  y CAIP 

COMMON  CAR3FC  p CASF  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y FA V6  < 5 ) ? PFSTSP  y PFAC  y RCLTEC ( 29  y 34 ) 

COMMON  TCAR ( 5 ) y THICK  < 1 0 ) y THKTS  y TTL ( 40 ) 

INTEGER  EXIT  y CLMA  y GDES  y GWHY  y OVBD  y SBSL 
I NTEGER  SCEC  y SUHY  y TPSL  y VGTA  y AMI M 
INTEGER  CLIMAT  y 6ENBES  y GRWHYB  y OVRBDN 
INTEGER  SOCECN ? SUBSOI y SURHYB y TOPSOI 
INTEGER  VEGE  f A y ANIMAL 

INTEGER  RCLIMA  s RGENDE  y RGRWHY  y ROVRBD y RSOCEC 
INTEGER  RSUBSO yRSLIRHYy  RTOPSO?  RVEGET  yRANIHA 
INTEGER  RCLTEC? TTL 


0096 


0103 

0104 

0105 

0106 


C 

C 

C 


INTEGER  COMMON  (1) 


0097 

EQUIVALENCE 

(COMMON 

( 1 ) 

y If  LK 

0098 

EQUIVALENCE 

( lARRY 

( 1 ) y 

LUT) 

0099 

EQUIVALENCE 

(IARY2 

(l)y 

ISTRK) 

0100 

EQUIVALENCE 

( XARY2 

( 2 ) y 

I SECT) 

0101 

EQUIVALENCE 

( IARY2 

( 3 ) ? 

I CODE) 

0102 

EQUIVALENCE 

(IARY2 

( 4 ) y 

LEN) 

LOGICAL  LER 


DISPLAY  MODE 


(1)) 


0107 

0108 

0109 

0110 


1 IF  (♦NOT ♦LER)  GOTO  5 
CALL  ERASE 
CALL  HOME 

5 G 0 1 U \ 1 0 y 2 0 y 3 0 ) (.  t E 
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0111 

0112 

0113 

011^ 

OHM 

0116 

0117 

0118 

0119 

0120 
0121 
0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 
01  36 

0137 

0138 

0139 

0140 

0141 

0142 
014  3 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 
0161 
.>162 

0163 

0164 

0165 

0166 


10  UR.TTE  (LUTylOlO) 


C 


t:. 

C 


C 

C 


C 


GOTO  40 

20  WRITE  < LOT r 2010) 

GOTO  40 

30  WRITE  (LUTy3010) 

40  IF  (HODE.GT^l)  GOTO  50 

GOTO  (100y200y300y400y500y600)  LEXIT 
USER  INPUT  ->  EDIT  HEADING 

50  WRITE  (LUTy2020) 

51  READ  (LUTy2030)  IANS 


IF 

(IAMS.EQ.2HA 

) 

GOTO 

100 

IF 

(IANS.EQ.2HB 

) 

GOTO 

200 

IF 

( 1ANS.EQ.2HC 

) 

GOTO 

300 

IF 

( IANS.EQ.2HD 

) 

G0(0 

400 

IF 

( IANS.EQ.2HE 

) 

GOTO 

500 

IF 

( IANS.E0.2HF 

) 

GOTO 

600 

IF 

( lANS.ECn2HN0) 

RETURN 

WRITE 

(LUl ? 1200) 

GOTO  51 

EDI!  EXPECTATIONS 

USER  INPUT  SUBHEADING  NUMBER 

55  WRITE  <LUTy3020) 

56  READ  (LUTy^:)  II 
GOTO  90 

USER  INPUT  ->  LAND  USE  OPTION  REFERENCE  NUMBER 

60  WRITE  (LUTy3030) 

61  READ  (LUTyX':)  LUORN 

IF  < LUORN  * GE  ♦ li.  AND.  LUORN  *LE.  6)  GOTO  65 
WRITE  <LUTyl200) 

GOTO  61 

65  11  11  T L 

USER  INPUT  ~>  EXPECTAf ION  OALUE 

70  WRITE  (LUTy3040) 

71  READ  (LUTy:{t)  SURHYD  ( II  y LUORN) 

IF  (SURHYD  (IlyLUORN) .GE.O* AND. SURHYD  < I I y LUORN ) ♦ LE . 4 ) 

T GOTO  700 
WRITE  (LUTy3050) 

GOTO  71 

EDIT  RESPONSES 

75  lOLD  = RSURHY  (NN) 

77  WRITE  <LUTy2040)  lOLD 
GOTO  85 

INPUl  RESPONSES 

USER  INPUT  ->  RSURHY  (NN) 

80  WRITE  (LUTy2000) 

85  READ  (LUTy)fO  RSURHY  ( NN ) 

II  RSURHY  (NN) 

IF  (lI.EQ.O)  GOTO  (900y91)  MODE 

90  IF  (Il.GE.l.AND.II.LE. ISUR  (NN) ) GOTO  ( 800 y 700? 60)  MODE 

91  WRITE  (LUT?I200) 

GOTO  (85? 85? 56)  MODE 

DISPLAY  HEADING  A ->  SURFACE  WATER 

100  NN  = 1 
J = 1 
L J~1 

I F ( MODE . EO . 1 . OR . . NOT . LER ) GOI 0 110 
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0167 

CALL  ERASE 

0168 

CALL  HOME 

0169 

110 

WRITE  (LUTy999) 

0170 

WRITE  (LUTy 1000) 

0171 

WRITE  (LUTy 1020) 

0172 

WRITE  (LUTy 1050) 

0173 

DO  115  K ==  7yl0 

0174 

WRITE  (LUTy 1100) 

0170 

115 

J J T 1 

0176 

120 

GOTO  (80y75y55)  i 

0177 

C 

DISPLAH 

0178 

200 

NN  ==  2 

0179 

J =••  ISLiR  (1)  i 1 

0180 

L J”1 

0 1 S 1 

IF  (*MOT*LER) 

0182 

CALL  ERASE 

0183 

CALL  HOME 

o 

CO 

WRITE  (LUly999) 

0185 

WRITE  (LUTy 1000) 

0186 

210 

WRITE  (LUTy 1020) 

0187 

WRITE  (LUTy 1050) 

0188 

DO  215  K ===  20y24 

0189 

WRITE  (LUTy 1100) 

0190 

215 

.1  = J + 1 

0191 

GOIO  120 

0192 

C 

DISPLAY 

0193 

300 

NN  = 3 

0194 

J = ISUR  (1)  + I 

0195 

L =-  J-1 

0196 

IF  (.NOT^LER) 

0197 

CALL  ERASE 

0198 

CALL  HOME 

0199 

WRITE  (LUTy 999) 

0200 

WRITE  (LUTy 1000) 

0201 

310 

WRITE  (LUTy 1020) 

0202 

WRITE  (LUTy 1050) 

0203 

DO  315  K = 26y28 

0204 

WRITE  (LUTy 1100) 

0205 

315 

J = J T 1 

0206 

GOTO  120 

0207 

C 

DISPLAY 

0208 

400 

NN  = 4 

0209 

J =•■  ISUR  (1)  -f  I 

0210 

L = J-1 

0211 

IF  (♦NOT^LER) 

0212 

C A L L E K’  A S E 

0213 

CALL  HOME 

0214 

WRITE  (LUTy 999) 

0215 

WRITE  (LUTy 1000) 

0216 

410 

WRITE  (LUTy 1020) 

0217 

WRITE  (LUTy 1050) 

0218 

DO  415  K 30?32 

0219 

WRITE  (LUTy 1100) 

0220 

415 

,J  J -1  1 

0221 

GOTO  120 

0222 

c 

DISPLAY 

1 ? 13) 

1 f 13) 


1 y 1 3 ) j K 


3 y 


6) 


lyl3)y  (SURHYD  (Jyl)yJ. 


AMOUNT  OF  k»ATEF< 


(SUHY  (lfl)?I  lyl3) 

(SWHY  (2yl)yl  = 1?13) 

( (SWHY  (Kyl)yl  = lyl3)yK  ==  llyl9) 

(SIaIHY  (Kyl)yl  ==  lyl3)y  (SURHYD  (J?I)yl 

HEADING  C ~>  INDEX  OF  DISSECTION 


1 ? 1 3 ) 


lyl3) 


1 r 13) 

1 y 1 3 ) 


■>  SALINIlY 


— 1 y 6 ) 


=^-  ly6) 


= 1 y 6 ) 


=-■  1 y 6 ) 
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0223 

0224 

0225 

0226 

0227 

0228 

0229 

0230 

0231 

0232 

0233 

0234 

0235 

0236 

0237 

0238 

0239 

0240 

0241 

0242 

0243 

0244 

0245 

0246 

0247 

0248 

0249 

0250 

0251 

0252 

0253 

0254 

0255 

0256 

0257 

0258 

0259 

0260 
0261 
0262 

0263 

0264 

0265 

0266 

0267 

0268 

0269 

0270 

0271 

0272 

0273 

0274 

0275 

0276 

0277 

0278 


5 


500  MM 

J - ISUR  (1)  -f  ISUR  (2)  -1  ISUR  <3)  -h  ISUR  (4)  + 1 
L = J-1 

IF  (*M0TJ.JIR)  GOTO  510 
CALL  ERASE 
CALL  HOME 

MRITE  (L‘JTy999)  (SWHY  (lyl)fl  1,13) 

WRITE  (LOT, 1000)  (SWHY  <2,1)?!  ^ 1,13) 

510  WRITE  (LUf,1020) 

WRITE  <LUr,1050)  ( (SWHY  <K?I),I  ==  1,13), K = 33,34) 

DO  515  K ==  35,38 

WRITE  (LOT, 1100)  (SWHY  (K,I),I  l,i3)y  (SURHYD  (J,I),I 


51 


\ 


J + 1 


ISUR  (2)  T ISUR  (3)  T ISUR  (4)  + ISUR  (5) 


( (SWHY  (K,I),I  = 1,13),K  ~ 39,40) 
(SWHY  (K,I),1  = 1,13),  (SURHYD  (J,I),I 


GOTO  120 

C DISPLAY  HEADIMG  F ->  SODIUM  ADSORPTIOM  RATIO 

600  MM  = 6 

J ISUR  (1) 

L J-1 

IF  (^MOTa..ER)  GOTO  610 
C A L L.  ERASE 
CAL.L  HOME 

WRITE  (LUI,999)  (SWHY  (1,1), I = 1,13) 

WRITE  (LUT,1000)  (SWHY  (2,1  ),I  ==  1,13) 

610  WRITE  (LUT,1020) 

WRITE  (LUI,1050) 

DO  615  K ==  41,44 
WRITE  (LUT,1100) 

615  J = J + 1 
GOTO  120 

C USER  INPUT  ->  MORE  EDITS  ? 

700  WRITE  (LUT,3060) 

READ  (LUT,2030)  IANS 

IF  (1AMS*ME*2HYE)  RETURN 
GOTO  1 

C INPUT  MODE  ->  DIRECT  TO  PROPER  HEADIMG 

800  IF  (MM,EQ»MSUR)  RETURN 

GOTO  (200,300,400,500,600)  MM 

C USER  WANTS  OUT  ->  SET  EXIT  TO  ZERO  AMD  RETURN 

900  EXIT  0 

RETURN 

C FORMAT  STATEMENTS 

999  FORMAT  ( 13A2) 

C 

1000  FORMAT  (13A2,44  ( “ “ ) , / , 26X , ‘ ‘ , 
glOX,  “STANDARD  EXPECTATIONS 1 IX , 
g.26X,44  ) ,/,26X,  “>f:CRaP^‘'  ,2X, 

SANATIVE*  ,2X,  “^4,jILD;^:“  ,2X,  "WATERS  ,3X, 

“ ^HI HER>K  “ , / , 26X  , 

JS“:^a.AND:{^ME6ETATI0NYLIFE^RECREATI0N:^USE  5fc«y5X,  ) 

C 

1020  FORMAT  (70  ( “ “ ) ? / , 26X , ^ “ 4X " :F:  * lOX *=  )f=: " 4X “ “ lOX  “ “ 4X  “ :F:  “ 5X “ 4 

C 

1050  FORMAT  ( 1 3A2 if:  4X lOX  4X  , 

^.lOX  4X  , “ Y “ , 5X  y “ t “ ) 

C 

1100  FORMAT  (13A2, 


” 1,6) 


+ 1 


— 1,6) 
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0279 

0280 
0281 
0282 
0283 
028^ 
0288 
0286 

0287 

0288 
0 289 

0290 

0291 

0292 

0293 

0294 
0293 

0296 

0297 
0 2 9 8 

0299 

0300 

0301 

0302 

0303 

0304 

0305 

0306 

0307 
0303 

0309 

0310 

0311 

0312 

0313 

0314 

0315 

0316 

0317 

0318 

0319 


^ "11*^-  "II*  t • 1 1 " -11“  * 1 1 " )fc  - 1 1 « 

C 

1200  rOF^lMAT  (/“YOU  HAVE  TYPEi.i  IM  AN  ILLEGAL  ANSWER*"? 

"GIVE  HER  ANOTHER  SHOT  ->  _-) 

C 

2000  EORHAT  ("ENTER  THE  APPROPRIATE  * 5X r 
^44  ( -:^"  )?/?  "NUMBER?  OR  ZERO  TO  QUIT 
C 

1010  FORMAT  ( 15X" INPUT  RESPONSES/SURFACE  WATER  HYDROLOGY"/) 

C 

2010  FORMAT  ( 15X"EDIT  RESPONSES/BURFACE  WATER  HYDROLOGY"/) 

C 

3010  FORMAT  ( 15X*EDIT  EXRECTATIONS/SURFAGE  WATER  HYDROLOGY"/) 

C 

2020  FORMAT  (5X"1N  WHICH  HEADING  IS  YOUR  DESIRED  EDIT?*/? 

£5X"  (ENTER  A?B?C?D?E?F?  OR  NONE)  ~>  _") 

C 

2030  FORMAT  (A2) 

C 

2040  FORMAT  (5X“Y0UR  CURRENT  RESPONSE  IS  ->  "12?// 

S5X" ENTER  YOUR  NEW  RESPONSE  HERE  ->  _") 

C 

3020  FORMAT  (5X"IN  WHICH  SUB-HEADING  IS  THE  EXPECTATION  VALUE*/? 
&5X"Y0U  WISH  TO  CHANGE  ? (ENTER  THE  APPROPRIATE  NUMBER) 

C 

3030  F0RMAT(/5X*SELECT  THE  LAND  USE  OPTION  YOU  WISH  TO  CHANGE"/ 

> IX"  -1“  / -2-  / -3-  / -4-  / -5-  / -6“  /*/ 

> 1X"CR0PLAND/NAT* VE6*/WILDLIFE/WAT *REC*/H1GH  USE/  OTHER/" 
>/5X* ENTER  YOUR  SELECTION  HERE  ->  _“) 

C 

3040  FORMAT  (5X“ENTER  YOUR  NEW  EXPECTATION  VALUE  HERE  ->  _") 

C 

3050  FORMAT  (/?  5X" ERROR — > YOUR  EXPECTATION  VALUE  MUST  BE*/? 
%5X*0?1?2?3?  OR  4 TO  AVOID  INTRODUCING  A BIAS  ->  _*) 

C 

3060  FORMAT  (5X?"ANY  MORE  EDITS  TO  SURFACE  WATER  HYDROLOGY?"/? 
^5X*  (YES  OR  NO)  = > _") 

C 

C 

END 

END$ 


) 
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MODE  yNANM  yNCLI  yNGEN 

NOL'R  yNSECTS  yNSGC  yNSUD 

NTOP  yNU  yNVEG 


y ISUD<3) 
yLUO 
y NGRU 
yNSUR 


CrsADING  PARAMETERS 


COMMON  AREA(5)  yDENLEN(5ylO)  yBENWI(c,yi 


•^0)  y C0G0yGCPA(5) 


COMMON  GRDVDS ( 5 ) y HUNT  < 5 y 10 ) y I lUSLi ( 5 y 1 0 ) y NSPP ( 5 ) y PCEOl 9 ( 4 ) 
COMMON  PERCNT ( 5 y 10 ) y REUCPY ( 5 ) y RE!  lOOL  < 5 ) y SLOPE ( 5 y 10) y UDP 

CATEGORY  TEXT 


COMMON  ANIM(23y 13) yCLMA(13yl3) yGDES(15yl3 
COMMON  C0DD(llyl3)ySDGE(13)y  SCEC(33yl3)y 
COMMON  TPSL(49y 13) y OGTAC 15y 13) 


/ yi_^wiiT  \ ju.4i.yJ.uj/ 

O I } Y r A A . i T \ 
vjwiil  \ ~t  —I  7 j.  y 


EXPECTATION 


MAI  I 11-0 
V M i_  Lm_  o 


COMMON  ANIMAL(13y6) yCLIMAT<8y6) yGENDES(Sy6) y GRUHYD ( 19 y 6 ) 
COMMON  OORBDN  < 28  y 6 ) y SOCECN ( 29  y 6 ) y SUBSO I ( 30  y 6 ) y SURM YD ( 23  y 6 ) 
COMMON  T0PS0K33y6)  y VEGETA  ( 10  y 6 ) 

CATEGORY  RESPONSES 

COMMON  RANIMA(3) yRCLIMA(2) y RGENDE ( 3 ) y RGRWHY  ( 5 ) 

COMMON  ROVRBD ( 7 y 1 0 ) y RSOCEC  C 6 ) y RSUBSO ( 8 ) y RSURH Y < 6 ) 

COMMON  RT0PS0(9) yRVEGET(2) 


FEASIyTECGNyOPUSE  SUBSYSTEM  PARAMETER 


COMMON  CAAI IM  y CABAH  y CABFN ( 3 ) y CABFP ( 3 ) y CABHM 

COMMON  CABS ( 2 ) y CAC  y CACP  y CADF  y CADH 

COMMON  CADSyCAEAFyCAHSAF  yCAHSTSyCAIP 

COMMON  CAR3FC  y CASE  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y FAVG  C 5 ) y PFSTSP  y PFAC  y RCLTEC  < 29  y 34 ) 

COMMON  TCAR ( 5 ) y THICK  < 10 ) y THKTS y TTL ( 40 ) 


INTEGER  EXIT  y CLMA  y GDES  y GUHY  y GVBD  y SDSL 
INTEGER  SCEC  y SUMY  y TPSL  y VGTA  y ANIM 
INTEGER  CLlMATyGENDESyGRUHYDyOVRBDN 
INTEGER  SOCECN y SUBSGl y SURHYD y TOPSOI 
INTEGER  VEGETAyANIMAL 

INTEGER  RCL IMA  y RGENDE  y RGRUHY  y ROVRBD  y RSOCEC 
INTEGER  RSUBSO  y RSURHY  y RTOPSO  y RVEGET  y RANI MA 
INTEGER  RCLTEC y TTL 
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0111 

0112 


C 


0119 

0120 
0121 
0122 

0123 

0124 

0125 

0126 
0127 

C^ 

j.  ^ w 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0130 

0139 

0140 


0141 

0142 

0143 
01^^ 


/\  ^ cr 

■»/  J.  “T  vJ 

r-  -i  A / 

N.'  X “T  \J 

0147 

014C 

0149 

0150 

0151 

0152 

0153 

0154 

0155 
01«=:/. 


0158 

0159 

0160 
0161 
0162 

0163 

0164 

0165 

0166 


C 

C 

C 

C 

C 

C 

C 

r' 

c 


c 

c 

c 


u? 

c 

n 


c 

c 

c 


c 

c 

n 


c 

c 

c 


INlEGEi;:  CCMMCN  (1) 


0113 

EQOIVALENCE 

(CONMON 

(1) 

y ITEK 

0114 

EQOIVALENCE 

(lARRY 

( 1 ) y 

LOT) 

0115 

EQUIVALENCE 

(IARY2 

(1)  y 

ISTRK) 

0116 

EQOIVALENCE 

(IARY2 

(2)  y 

ISECT) 

0117 

EQOIVALENCE 

(IARY2 

(3)  y 

ICODE) 

one 

EQUIVALENCE 

(IARY2 

(4)  y 

LEN) 

LOGICAL  LER 
INTEGER  IWHERE  (10) 

REAL  NTFR 

INITIALIZE  IWRERE  ARRAY 

DC  5 I = ly  NU 
5 IWilLRE  (I)  = 0 


IRIP  = 0 


ri r-  7 r* T ir • t ‘ 1 1 “ 

JL*  I—  i L-  I \ I > J.  I X 1_  I I I L_ 


TOTAL  THICKNESS  AND  THE  NININUM  THICKNESS  FOR  REHANDL 


TOTTHK 
DO  10  I 
10  TOTTHK 
NTI'R 


0* 

= ly  NO 

TOTTHK  -{  THICK  (I) 


TOTTHK  t 


i vr 


CHECK  THE  NOHDER  OF  ROCKS 


DO  25  I 


-t 

X y 


NO 


THICK  (I)  *LT*  NTFR)  GOTO  25 


IF  (RO'v'l^’DD  (ly  I)  *NE*  4 *01 
I WHERE  (I)  = I 

cr  p rv  ij  T-  T V M H.r 
^ L-u>lxixlxUi_ 


CHECK  THE  SALINITY 
DO  35  I = ly  NO 

IF  (RCVRDD  (4yl)  *NE*  5 *0R*  THICK  (I)  *LT*  NTFR)  GOTO  35 
I WHERE  (1)  = I 

•7  p n I f T X n j i r 

CHECK  THE  SODION  ADSORPTION  RATIO 
DO  45  1 = ly  NO 

IF  (RCORDD  (5yl)  ♦ NE ♦ 4 ♦ OR ♦ THICK  (I)  *LT*  NTFR)  GOTO  45 

I WHERE  (I)  = I 
45  CONTINOE 

CHECK  FOR  ALLUVION 

50  1F(LU0*EQ*5)  GOTO  600 

IF(RGRWHY(5)  *EG*1)  IWHERE  (1)  = 1 

RECHECK  SALINITY  l-OR  CROPLAND  AND  NATIVE  VEGETATION 
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0167 

IF(LU0*GT*2)  GOTO  500 

0168 

DO  55  1=1 yNU 

0169 

IF ( ROORBD  < 4 » I ) . NE ♦ 4 ♦ OR ♦ THICK (I ) ♦ LT ♦ MTFR ) 

GOTO  55 

0170 

I WHERE  <I)  = I 

0171 

0172 

C 

er  tr 
xJxJ 

COmiHUE 

0173 

C 

RECHECK  NUMBER  OF  ROCKS  FOR  CROPLAND 

0174 

0175 

C 

56 

1F(LU0.NE»1)  GOTO  500 

0176 

DO  60  1=1 ?NU 

0177 

IF  < RO'v'RBD  ( 1 y I ) ♦ NE  ♦ 3 ♦ OR  ♦ THICK  < I ) ♦ LT  * M l FR  ) 

GOTO  60 

0178 

I WHERE  <I)  = I 

0179 

0180 

C 

60 

CONTINUE 

0181 

0182 

C 

c 

CHECK  BULK  DENSITY 

0183 

500 

DO  510  I = ly  NU 

0184 

IF  (R0VRBD(3yI) ♦ NE ♦ 2 ♦ OR ♦ THICK ( I ) ♦LT*MTFR) 

GOTO  510 

0185 

IRIP  = 1 

0186 

510 

CONTINUE 

0187 

600 

1 CHECK  = 0 

0188 

DO  610  I = ly  NU 

0189 

IF  (I WHERE  (I)  ♦EQ.  0)  GOTO  610 

0190 

ICHECK  = 1 

0191 

610 

CONTINUE 

0192 

RETURN 

0193 

END 

0194 

LNDtf- 
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STCONE 


T==00004  IS  ON  CR00015  USING  00022  BLKS  R=0144 


0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 

0053 

0054 


IS 


TN4 


C 

C 

C LEOEL  1 
C 


C 

C 

C 

C 

C 

C 

C 

C 

C 

C 


SUDROUIINE  TCONE 
•TECON  COST  EDIT- 


TCONE 
FILE  : 
IN  THE 


A I . 


• p A y 

V l 'v  n l 


TCOST  WILL  OVERWRITE  THE  PREVIOUS  CCF 

AFT  E R EDITING.  0 T 1 1 E R W I S 
VALID  ONLY  UNTIL  tmtq 
THE  FILE  CCf 


SO  INDICATES 
VALUES  ARE 
(IN  WHICH 


ERMANENT  CHANGES  TO  THE 
GETS  ENTRIES  ARE  STORED 
TCOSTy  WHICH  IS  PROCESSED  FOR  USEl 

FILE?  IF  THE 
THE  EDITED  TF 


SCHEDULED  BY  CLAIM  TO  MAKE  P 
CCFTSy  THE  TECON  COST  FILE.  C 
LOCAL 


TS 

E» 


: EDITS 
USER 


THIS  ROUT 


CASEy 


TS 


IS 


REA 


THE  PREVIOUS  EDITS)  y OR  UNTIL  (SURPR 
TERMINATES. 


:coN 

INE  IS  CALLED  AGAIN 
D AGAIN y OVERWRITING 
ISINGLY)y  CLAIM 


C 

C THE  USER  MUST  CORRECTLY  ENTER  THE  SECUiaTY  CODE  ’RECMOD"  TO 
C MAKE  THE  EDITS  PERMANENT 
C 

C TCONE  USES  THE  SYSTEM  ROUTINE  “SPOLU*  TO  ACCESS  THE 
C FILE  'CCFTS* 

C 

C THE  TCS  ROUTINES  : ERASE  AND  HOMEy  ARE  CALLED. 

r- 

C THIS  ROUTINE  WAS  WRITTEN  BY  GREEN 
C 


C CLAIM  RELEASE  1.0  ~ APRIL  ly  1980 

C 


C 

C 

C 

C 


TEKTRONIX  COMMON 


C 

C 

C 

C 

C 


C 


C 

C 

C 


C 


COMMON  ITEK  (45) 


LOGICAL  UNITS  AND  COMMON  LOCATION 
COMMON  IARRY(5) y I ARY2 ( 5 ) y LER y LUF y LUL 
POINTERS 

COMMON  EXIT  y IANM(3) y ICLI (2) y IGEN(3) y 1GRW(5) 
COMMON  lOPTN  y IGVR(7) y IPNTR  y IS0C(6) y IGUB(G) 
COMMON  ISUR(6) y IT0P(9) y 1VEG(2) yLEXIT  yLUO  , 
COMMON  MODE  yNANM  yNCLI  yNGEN  yNGRW 

COMMON  NOVR  yNSECTS  yNSOC  yNSUB  yNSUR 

COMMON  NTOP  yNU  yNVEG 

G R A D I N G F*  A R A MET  E R’  S 


COMMON  AREA  (5)  y BENLEN  ( 5 y 1 0 ) yBENWKSylO)  y COGO  y GCPA ( 5 ) 
COMMON  GRDVBS(5) yHWHT(5y 10) yllWSLI (5y 10) yNSPP(5) yPCEQ19(4) 
COMMON  PERCNT ( 5 y 1 0 ) y REHCPY ( 5 ) y REHVOL ( 5 ) y SLOPE ( 5 y 1 0 ) y WBP 


it 
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0055 

0056 

0057 

0058 

0059 

0060 
0061 
0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 
0081 
0082 

0083 

0084 

0085 

0086 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 
0101 
0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


C 

C 


C 

C 

C 


C 

C 

C 


C 

C 

C 


C 


C 


C 


c; 

c 

c 


c 


CATEGORY  TEXT 

COMMON  ANIM(23y 13) » CLMA ( 1 3 y 1 3 ) , GDEG ( 1 5 y 1 3 ) y GUI  lY ( 22 y 1 3 ) 
COMMON  00i;-!D<llyl3)ySBSL<13)y  SCEC  < 33  y 13  ) y SUM  Y < 44  y 13  ) 
COMMON  TPSL (4?yl3)yVGTA(15yl3) 


EXPECTATION  OAl 


Uiro 


COMMON 

COMMON 

COMMON 


ANIMAL(13y6) yCLIMAT(8y6) yGENDES(8y6) yGRUHYD(19y 

N(29y6)  ySUBS0K30y6)  yGURHYD(2 


00RBDN(28y6) ySOC 


ir  n 


TOPSOI  < 33  y 6 ) y 'v'EGE TA  ( 1 0 y 6 ) 


CATEGORY  RESPONSES 


COMMON  RANIMA(3) yRCLIMAC2) yRGENDE(3) yRGRUHY(5) 
COMMON 
COMMON 


R00RBD(7y 10) y 


RS0CEC(6) yRSUBS0(8) yR^ 


oURMYC6) 


RT0PS0<9)  yR'v'EGET(2) 


EEASIyTECONyOPUSE 


SUBSYSTEM 


PARAMETERS 


COMMON  CAAMM  y CABAH  y CABFN  < 3 ) y CABFP ( 3 ) y CABHM 

COMMON  CABS ( 2 ) y CAC  y CACP  y CABF  y CABH 

COMMON  CADS  y CAEAF  y CAMSAF  y CAHSTS  y CAIP 

COMMON  CAR3FC  y CASF  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y FAOG ( 5 ) y PFSTSP  y PFAC  y RCLTEC ( 29  y 34 ) 

COMMON  TCAR<5) y THICK(IO) y THKTSy ITL(40) 

INTEGER  EX I T y CLMA  y GDES  y GUH Y y OOBD  y SBSL 
INTEGER  SCEC  y SUHY  y TPSL  y OGTA  y ANl M 
INTEGER  CL IMAT  y GENBES  y 6RUHYD  y OORBDN 
INI  EGER  SOCECN  y SUBSOI y SURHYD  y TOPSOI 
INTEGER  VEGETA y ANIMAL 

INTEGER  RCLIMAyRGENBEyRGRUHYyROVRBDyRSOCEC 
INTEGER  RSUBSO  y RSURHY  y RTOPSO  y RVEGE T y RANI MA 
INTEGER  RCLTEC yTTL 


INTEGER  COMMON  <1) 


EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 


(COMMON  (1) 
(lARRY  <l)y 
(IARY2  (l)y 
(IARY2  (2)y 
(IARY2  (3)y 
(1ARY2  (4)y 


ITEK  (1)) 
LUT) 

ISTRK) 

I SECT) 

I CODE) 

LEN) 


LOGICAL  LER 


DIMENSION  TC0STC25) 

EQUIVALENCE  (TCOST(l) yCAAHM) 
INTEGER  KTC0ST(25y30) yCCFTS(3) 
INTEGER  RECM0D(3) 

BATA  CCFTS/2HCCy2HFTy2HS  / 

DATA  ICR/15/ 


C OPEN  CCFTS  / READ  7 COST  / CLOSE  CCF TS 
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W On 


0111  c 


0112 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120 
0121 
0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 


CALL  SPOLU ( LUF » CCFTS  y 2 » 1 ? I CR ) 

IF(LUF*LT»0)  STOP  1 
DO  10  K=ly25 

10  READ(LUF  y 15)  TCOST  ( K ) s*  ( KTCOST  ( K , I ) , 1 = 1 , 30 ) 

15  F0RMAT(lX»F6.3y2X,40A2) 

CALL  SP0LU(LUFyCCFTSy2y2y ICR) 

IF(LUF*LT*0)  STOP  2 
C 

C READ  EDIT  ITEM 
C 

20  IF(LER)  CALL  ERASE 
IF(LER)  CALL  HOME 
DO  25  K=ly25 

25  WRITECLUTy 30)  K y ( KTCOST < K y I ) y 1=1 y 30 ) y TCOST ( K ) 

30  FORMAT  ( IX y 12“  ) “ IXy  30A2y  1X“  : “ y.F6*3) 

WRITE(LLITy  35) 

35  FORMAT (/y IX •E^F^ER  NUMBER  CORRESPONDING  TO  EDIT  ITEM"/y 
> IX • (ZERO  TO  QUIT)  ~>  _") 

40  READ(LUIy)^)  ITEM 

IF(ITEM*EQ*0)  GOTO  100 
lF(ITEM»GE*l*ANDtITEM*LE*25)  GOTO  50 
WRITE(LUT  y45) 

45  FORMAT(/y IX’ERROR*  ILLEGAL  ENTRY*  RE-INPUT  ->  _") 

GOTO  40 
C 

C READ  NEW  VALUE  FOR  TCOST  “ITEM“ 

C 

50  WRITE (LUTy 55) 

55  FORMAT (/IX “ENTER  NEW  VALUE  ->  >.') 

60  REAIKLUTy  >i^)  TCOST(ITEM) 

IF(TCOGTdTEM)  *GE*0*  ) GOTO  20 
WRITE(LUTy45) 

GOTO  60 
C: 

C SEE  IF  USER  WANTS  TO  MAKE  CHANGE  PERMANENT ♦ IF  SO 
C HE  MUST  CORRECTLY  INPUT  THE  SECURITY  CODE  “RECMOD* 

C 


0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 
0161 
0162 

0163 

0164 

0165 

0166 


100  WRITE(LUTy 1015) 

1015  F0RMAT(5X“T0  MAKE  CHANGES  PERMANENT y ENTER  THE'/ 

> 5X“SECUR1TY^ CODEy  OTHERWISE  ENTER  NO  _“) 

READ(LUTy 1016)  RECMOD 

1016  FORMAT (3A2) 

IF(RECM0D(1) *NE*2HRE)  RETURN 
IF ( RECMOD ( 2 ) ♦ NE ♦ 2HCM ) RETURN 
IF(RECMCD(3) *NE*2H0D)  RETURN 

n 

w 

C WRITE  OVER  PREVIOUS  FILE  AND  QUIT* 

C 

CALL  SPOLU ( LUF  y CCFTS  y 3 y 1 y I CR ) 

1F(LUF*LT*0)  STOP  3 
DO  115  K = ly25 

115  WRITE (LUF y 15)  TCOST(K) y (KTCOST (Ky I ) y 1=1 y 30) 

CALL  SPOLU(LUFy CCFTSy 3y2y ICR) 

IF(LUF*LT*0)  STOP  4 
RETURN 
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STCCN4  r=00004  I 


^ CR00015  USING  00016  BLKS  R==0000 


0001 

0002 

0003 
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0005 


OOOo 


0007 
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0007 
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0011 

0012 

0013 

0014 


00." 


0016 

0017 


0013 


0019 

0020 
0021 
0022 


002; 


0024 


002! 


0026 


.o 
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0023 

0029 

0030 

0031 

0032 


0033 


0034 


007>‘ 
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0037 


003^^ 


0039 

0040 

0041 
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00-^-^ 


' “Tf  W 

0047 


004P 
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FTN4 

C = = = = = = =:  = = = = = = 

c = 
c = 
c = 

C = SOURCE  FILE  t STC0N4 


SUBROUTINE  TC0N4 


TECON  : GOOD  SUBSOIL  PRESENT 


OBJECT  FILE  t %TC0N4 


U/ 


c 

c 

c 

c 

c 

c 


r»ir  oor*  T c*T  T n’^J  ■* 

l.>i_vJoi\u.a  1 lUii  * 


TCGN4  TESTS  FOR  THOSE  ENVIRONMENTAL  PARAMETERS  THAI y IN  THE 
a^’RESENCE  OF  A GOOD  TOPSOIL  LAYER?  INDICATE  THAT  AN  ADEQUATE 
SUBSOIL  LAYER  IS  PRESENT* 


r- 

Ur 


CALLING  sequence: 


c 

c 


CALL  TC0N4  (I CHECK) 


r- 

lu 


arguments: 


c 

o 


TCHECK 


SET  TO  ONE  IF  GOOD  SUBSOIL  IS  PRESENT 


C 

C 

C 

c 

c 

c 

c 

c 

c 

c 

c 

c 


ACCESSED  by: 


TECON 


SUBROUTINES  SCHEDULED: 


LOCAL  variables: 


NONE 

NONE 


AUTHOR : 


ORVILLE  D*  GREEN 


r- 

U/ 


CLAIM  RELEASE  1*0  - APRIL  1?  1980 


n 


c 

c 


I 


I 


I 


I 


f' 

Ur 


C 


SUBROUTINE  TC0N4  (1 CHECK) 


C 

C 

C 

C 


TEKTRONIX  COMMON 


COMMON  ITEK  (45) 


C 

C 


LOGICAL  UNITS  AND  COMMON  LOCATION 


COMMON  IARRYC5) ? I ARY2 < 5 ) ? LER? LUF ? LUL 


C 

C 

C 


POINTERS 


? 1ANM(3) ? ICLI (2) y IGENC3) ?1GRW<5) 


COMMON  EXIT 
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005ti 

0056 

0057 

0058 
005? 
0060 
0061 
0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 
0081 
0082 

0083 

0084 

0085 

0086 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 
0101 
0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


C 

n 

c 


c 

c 

c 


c 

c; 

c 


c 

c 

c 


c 

c 

c 


c 


c 


c 


COHhON  lOPTN  yI00r<(7)  y IPNTR  y ISOC ( 6 ) y ISUH ( 8 ) 
COMMON  ISUR(6) y IT0P<9) y I0E6<2) yLEXIT  yLUO 
COMMON  MODE  yNANM  yNCLl  yNGEN  yNGRW 

COMMON  NO’v'R  yNSECTS  yNOOC  yNSUB  yNGUR 

COMMON  NTOP  yNU  yNVEG 

GRADING  PARAMETERS 


COMMON 

COMMON 

COMMON 


AREA ( 5 ) y BENLEN ( 5 y 1 0 ) y BENO I < 5 y 1 0 ) y COGO  y GCP A ( 5 ) 
GRDOBS ( 5 ) y HWMT  < 5 y 1 0 ) y HWSLl ( 5 y 1 0 ) y NGPP ( 5 ) y PCEQl 9 ( 4 ) 

nPT  « in  ^ « LIMP 


ERCNTCoy 


1 0 ) y REHCP Y < 5 ) y REHOOL  < 5 i 


PA  , 


CATEGORY  TEXT 

COMMON  ANIM(23y  13)  yC;LMA<13yl3)  yGDES<15yl3)  yG0!IY(22y  13) 
COMMON  00BD<llyl3)ySBSL(13)y  SCEC ( 33 y 13 ) y SWH Y ( 44 y 1 3 ) 
COMMON  TPSL(49y 13) yVGTA(15yl3) 


EXPECTATION  VALUES 


COMMON 

COMMON 

COMMON 


ANIMAL  < 13  y 6 ) y CL I MAT ( 8 y 6 ) y GENBES ( 8 y 6 ) y GRUI  lYB  < 1 9 y 6 ) 
OVRBDN  C 28  y 6 ) y SOCECN ( 29  y 6 ) y SUBSO I ( 30  y 6 ) y SURH YD ( 23  y 6 ) 
T0PS0I(33y6) y VEGETA(10y6) 


CATEGORY  RESPONSES 


COMMON  RANIMA(3) yRCLIMA(2) y RGENDE < 3 ) y RGRUHY < 5 ) 
COMMON  R0VRBD<7y 10) yRS0CEC(6) yRSUBSO(S) yRSURHY(6) 
COMMON  RT0PS0<9) yRVEGET(2) 


FEASIyTECONyOPUSE  SUBSYSTEM  PARAMETERS 

COMMON  CAAHM  y CABAN  y CABFN ( 3 ) y CABFP ( 3 ) y CABHM 

COMMON  CABS ( 2 ) y CAC  y CACP  y CADF  y CADH 

COMMON  CADS  y CAEAF  y CAHSAF  y CAHSTS  y CAI P 

COMMON  CAR3FC  y CASE  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y FA VG ( 5 ) y PFSTSP  y PFAC  y RCLTEC  < 29  y 34 ) 

COMMON  TCAR<5) y THICK(IO) y THKTS y TTL < 40 ) 


INT  EGER  EXI T y CLMA  y GDES  y GWH Y y DVBD  y SBSL 
INTEGER  SCEC  y SWH Y y TPSL  y VGTA  y ANl M 
INTEGER  CL 1 MAT  y GENDES  y GRWHYD  y OVRBDN 


INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 


SOCECN y SUBSOI y SURHYD y TOPSOI 
VE6E I Ay  ANIMAL 

RCLIMA  y RGENDE  y RGRWI  lY  y ROVRBD  y RSOCEC 
RSUBSO  y RSURHY  y RTOPSO  y RVEGET  y RANIMA 
RCLTECy TTL 


INTEGER  COMMON  <1) 


EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 


(COMMON  (l)y 
(lARRY  <l)y 
(IARY2  (l)y 
(IARY2  (2)y 
(IARY2  (3)y 
(IARY2  (4)y 


ITEM 
LUT  ) 
ISTRK) 
ISECT) 
ICODE) 
LEN) 


(1)  ) 
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0111 

0112 

0113 

0114 

0115 

0116 

0117 

0118 

01 19 

0120 
0121 
0122 

0123 

0124 

0125 

0126 


LOGICAL  LER 
C 
C 

IF<LU0»EQ*1)  GOTO  100 
C 

1 r ( RSUBSO  ( 1 ) ♦ ECU  1 . OF-;  ♦ RSUBSO  ( 2 ) ♦ EQ  ♦ 1 ♦ 

“ OR ♦ RSUBSO ( 2 ) ♦ EQ ♦ 6 ♦ OR . RSUBSO ( 5 ) ♦ EQ ♦ 5 ♦ 

- 0R*RSUBS0(6) *EQ*4)  I CHECK  = 1 
RETURN 

C 

100  IFCRSUBSOd  ) ♦ ECU  1 ♦OR*  RSUBSO (2)  *ECU1 
-■  ♦ OR  ♦ RSUBSO  ( 2 ) ♦ GE  ♦ 5 ♦ OR  ♦ RSUBSO  ( 5 ) ♦ GE  ♦ 3 

- ♦0R*RSUBS0(6) *GE.3)  I CHECK  = 1 
RETURN 

END 

ENBf- 
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FTN4 

C ============== 

c = 
c = 
c = 

C = SOURCE  FILE  ; STC0N5 


======  SUBROUTINE  IC0N5 

TECON  : IRRIGATE  PLANTINGS  CHECK 


OBJECT  FILE 


/b  I U I f l_> 


bescription: 

TC0N5  TESTS  FOR  THOSE  ENVIRONMENT AL  PARAMETERS  THAT  INDICATi 


THE  TECHNIQUE 


CALLING  sequence: 


C 
C 
C 
C 
C 
C 
C 
C 
C 
C 

c 
c 
c 
c 
c 
c 
c 
c 
c 

r* 

Uf 

c 
c 
c 
c 

c author: 


n* 

Ur 

n 

Ur 

c 

c 

c 

o 

Ur 


IRRIGATE  PLANTINGSy  SHOULD  BE  IMPLEMENTED 


CALL  TC0N5  (I CHECK) 

arguments: 

ICHECK  ->  SET  TO  ONE  IF  THE  TECHNIQUES  SHOULD  BE  IMPLEMENTED 
ACCESSED  by: 


TECON 


SUBROUTINES  SCHEDULED: 


LOCAL  variables: 


NONE 

NONE 

ORVILLE  D<  GREEN 


CLAIM  RELEASE  1*0  - APRIL  ly  1980 


C 

C 

r* 


Of  ir»rtor  IT  T i M - TooMf  / i ii  'ot-' \ 
t X IXI_  I \ Jl  UrI  / 


T VTl'ip*  I T V r-OijfWOM 

i L-i\  I isUit  X A II  lUit 


c 

c 

c 

c 

c 

c 


COMMON  ITEK  (45) 


LOGICAL  UNITS  AND  COMMON  LOCATION 


COMMON  IARRY(5) y IARY2(5) yLERyLUFyLUL 


POINTERS 

COMMON  EXIT 
COMMON  lOPTN 


y 1ANM(3) y ICLI (2) y IGEN(3) y I6RW(5) 
y I0VR(7) y IPNTR  y IS0C(6) y ISUD(S) 
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0055 

0056 

0057 

0058 

0059  C 

0060  C 

0061  C 

0062 

0063 

0064 

0065  C 

0066  C 

0067  C 

0068 

0069 

0070 

0071  C 

0072  C 

0073  C 

0074 

0075 

0076 

0077  C 

0078  C 

0079  C 

0080 
0081 


COMMON  ISUR<6)  5. 1T0P(9)  , I0E6<2)  ,LEXIT  ,LUO 

COMMON  MODE  »NANM  »NCLI  »NGEN  •NORW 

COMMON  NOOR  yNSECTS  »NSOC  >NSUD  ^NSUR 

COMMON  NT  OP  ^NU  »N0E6 

GRADING  PARAMETERS 

COMMON  AREA  < 5 ) , DENLEN  < 5 » 1 0 ) » BENWI ( 5 > 1 0 ) » COGO » GCPA  < 5 ) 

COMMON  GRD0BS(5)  yHUHKSy  10)  yhiySLKSy  10)  yNGPP(5)  yPCEQ19<4) 
COMMON  PERCNT<5y 10) yREHCPY(5) yREH00L(5) ySL0PE(5y 10) yUBP 

CATEGORY  TEXT 

COMMON  ANIM(23yl3)y  CLMA  < 1 3 y 1 3 ) y ODES ( 1 5 y 1 3 ) y GWH Y ( 22  y 1 3 ) 
COMMON  00BD(llyl3)ySBSL(13)y  GCEC(33y 13) y SWHY<44y 13) 

COMMON  TPSL(49yl3) yOGTA(15y 13) 

EXPECTATION  VALUES 

COMMON  ANIMAL(13y6) y CLIMAT ( 8 y 6 ) y 6ENDES ( 8 y 6 ) y GRUHYD < 19 y 6 ) 
COMMON  0VRBDN(28y 6) y SCCECN ( 29 y 6 ) y SUBSOI ( 30 y 6 ) y SURHYD < 23 y 6 ) 
COMMON  T0PS0I(33y6) y VEGETA(10y6) 


CATEGORY  RESPONSES 

COMMON  RANIMA<3) yRCLIMA<2) yRGENDE(3) yRGRUHY(5) 
COMMON  R0VRBD(7y 10) y RSOCEC ( 6 ) y RSUBSO < 8 ) y RSURI lY ( 6 ) 


0082  COMMON  RTOPSO < 9 ) y RVEGET < 2 ) 

0083  C 

0084  C FEASIyTECONyOPUSE  SUBSYSTEM  PARAMETERS 


0085  C 

0086  COMMON  CAAHM  y CABAH  y CABF  N ( 3 ) y CABFP ( 3 ) y CADI  IM 

0087  COMMON  CABS < 2 ) y CAC y CACP y CADF y CADH 

0088  COMMON  CADS  y CAEAF  y CAHSAF  y CAHSTS  y CAIP 

0089  COMMON  CAR3FC  y CASF  y CASNC  y CGTES  y CSTRM 

0090  COMMON  CSTRP  y FAVG  < 5 ) y PFSTSP  y PFAC  y RCLTEC ( 29  y 34 ) 

0091  COMMON  TCARC5) y THICK(IO) y THKT S y TTL ( 40 ) 

0092  C 

0093  INT  EGER  EXI T y CLMA  y GDES  y 6U!1  Y y OVBD  y SBSL 

0094  INTEGER  SCEC  y SWI!Y  y TPSL  y VGTA y ANIM 

0095  INTEGER  CLIMAT y GENDES y GRWH YD y OVRBDN 


0096 

0097 

0098 

0099 


INTEGER  SOCECNy SUBSOI y SURHYD y TOPSO I 
INTEGER  VEGETAy ANIMAL 

INTEGER  RCL I MA  y RGENDE  y RGRUHY  y ROVRBD  y RSOCEC 
INTEGER  RSUBSO  y RSURHY  y RTGPSO  y RVEGET  y RANIMA 


0100  INTEGER  RCLTECyTTL 

0101  C 


0102 

INTEGER  COMMON  <1) 

0103 

EQUIVALENCE 

(COMMON 

(1  ) 

y ITEK 

0104 

EQUIVALENCE 

( lARRY 

(1  ) y 

LUT  ) 

0105 

EQUIVALENCE 

(IARY2 

( 1 ) y 

ISTRK) 

0106 

EQUIVALENCE 

(IARY2 

(2)  y 

ISECT) 

0107 

EQUIVALENCE 

(IARY2 

(3)  y 

I CODE) 

0108 

EQUIVALENCE 

(1ARY2 

(4)  y 

LEN) 

0109  C 

0110 

LOGICAL  LER 

<D) 
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f 


0111  c 

0112  C 

0113  C 

0114  C 

0115  C Check  evere^e  precipitation 

0116  C 

0117  ir(RCLIMA(l > ♦EQ*1)  GOTO  50 

0118  C 

0119  IF(LU0*EQ*2»0rwLU0*EQ*3*0R*LU0*EQ*5)  RETURN 

0120  IFCRCLIMAd)  ♦NE\2)  RETURN 

0121  C 

0122  C )jc)ic)fo{^)^c:^c5{c  Check  surface  and  ground  water  for  LUO 

0123  C I 

0124  50  G0y0(60f70,70yB0f90)  LUO  I 

0125  C 


0126 

60 

IF<RSURHY<2)  *GE* 

3 *AND* 

RSURHY(5) 

♦ LE*  2 

0127 

t ♦AND*  RSURHY(6) 

♦LE*  2) 

I CHECK  = 1 

0128 

IF(RGRWHY(2)  *GE» 

3 *AND« 

RGRUHYC3) 

* LE  * 2 

0129 

t .ANTU  RGRWHY(4) 

♦LE*  2) 

ICHECK  = 1 

0130 

RETURN 

0131 

0132 

C 

70 

1F(RSURHY(2)  tGE* 

2 ♦AND< 

RSURHY<5) 

♦ LE*  3 

0133 

t ♦ANIU  RSURHY<6) 

♦LE^  3) 

ICHECK  = 1 

0134 

1F<RGRWHY<2)  *GE* 

2 ♦AND* 

RGRWHYC3) 

♦ LE*  3 

0135 

t ♦AND*  RGRWHY(4) 

♦LE*  3) 

ICHECK  = 1 

0136 

0137 

C 

RETURN 

0133 

0139 

C 

80 

IF<RSURHY(2)  *GE* 

4 *AND* 

RSURHY<5) 

♦ LE*  3 

0140 

t *AND*  RGURHY(6) 

♦LE*  2) 

ICHECK  = 1 

0141 

IF<RGRWHY(2)  ♦GE* 

4 *AND* 

RGRWHY<3) 

♦ LE*  3 

0142 

>f:  ♦ANru  R6RUHYC4) 

♦LE*  2) 

ICHECK  = 1 

0143 

RETURN 

0144 

0145 

C 

90 

IF(RSURHY(2)  ♦GE* 

2 *AND* 

RSURHY<5) 

♦LE*  3* 

0146 

t ANIU  RSURHY<6)  ♦ 

LE*  3)  1 CHECK  = 1 

0147 

IF(RGRUHY<2)  *GE* 

2 *AND* 

R6RUHY<3) 

♦LE*  3 *AND* 

0148 

t R6RWHY(4)  *LE*  3 

♦AND*  RGRWHY(5)*EQ 

*2)  ICHECK  = 

0149 

RETURN 

0150 

0151 

EN 

m 

END 

it 


/ 
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0020 
0021 
0022 

0023 
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0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 
-9 

0050 

0051 

0052 

0053 

0054 


004  V 


f 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 
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SUBROUTINE  TECON 


TECHNIQUES  ANB  ECONOMICS  SUBSYSTEM 


= SOURCE  FILE  t &TECON 


OBJECT  FILE  : %TECON 


description: 

TECON  IS  ACCESSED  BY  CLAIM  TO  DETERMINE  THE  TECHNIQUES  AND 
ECONOMICS  LISTING  FOR  THE  FIOE  LAND  USE  OPTIONS*  THE 
LIST  IS  PRESENTED  IN  THE  ORDER  THAT  THE  RECLAMATION 
ENGINEER  WOULD  NORMALLY  APPLY  EACH  TECHNIQUE*  THE 
FIVE  LAND  USES  ARE  PRESENT  FROM  LEAST  TO  MOST  EXPENSIVE 

SUBROUTINES  SCHEDULED: 

TCONO 

TCONl 

TC0N2 

TC0N3 

TC0N4 

TC0N5 


THIS  ROUTINE  WAS  WRITTEN  BY  GREEN 


CLAIM  RELEASE  1*0 


APRIL  If  1980  ){(){: 


C 

C 

C 


SUBROUTINE  TECON 
TEKTRONIX  COMMON 
COMMON  ITEK  (45) 

LOGICAL  UNITS  AND  COMMON  LOCATION 
COMMON  1 ARR Y ( 5 ) > 1 ARY2 ( 5 ) > LER » LUF , LUL 
POINTERS 

COMMON  EXIT  ? IANM(3) y ICLI (2) y I6EN(3) » IGRWCS) 
COMMON  lOPTN  » I0VR<7) ? IPNTR  » IS0C<6) > ISUB(8) 
COMMON  ISUR(6) ? IT0P(9) , 1 VE6 ( 2 ) > LEXI T yLUO 
COMMON  MODE  »NANM  yNCLl  yNGEN  yNGRW 

COMMON  NOVR  yNSECTS  »NSOC  yNSUB  yNSUR 

COMMON  NTOP  y NU  yNVEG 

GRADING  PARAMETERS 


268 


I 


0055 

0056 

0057 

0058 

0059 

0060 

0061 

0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 

0081 

0082 

0083 

0084 

0085 

0086 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 

0101 

0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


COMMON  AF<EA  ( 5 ) y BENLEN  < 5 y 1 0 ) y BENWI  ( 5 y 1 0 ) y COGO  y GCPA  ( 5 ) 
COMMON  GRDOBS ( 5 ) y HWI  (T ( 5 y 1 0 ) y HWSLI ( 5 y 1 0 ) y NGPP ( 5 ) y PCEQl 9 ( 4 ) 
COMMON  PERCNT<5y  10)  yREHCPY<5)  y F^EHOOL  ( 5 ) y SLOPE  < 5 y 1 0 ) y WBP 
C 

C CATEGORY  TEXT 

C 

COMMON  ANIM<23y 13) yCLMA(13y 13) yGDES<15y 13) y6WHY(22y 13) 
COMMON  00BD(llyl3)ySBSL<13)y  SCEC ( 33 y 13 ) y SWHY < 44 y 13 ) 
COMMON  TPSL<49yl3)yV6TAC15yl3) 

C 

C EXPECTATION  VALUES 

C 

COMMON  ANIMAL(13y6) yCLIMAT(8y6) yGENDES(8y6) y6RWHYD(19y 
COMMON  0VRBDN(28y6) y SOCECN < 29 y 6 ) y SUBSOI ( 30 y 6 ) y SURHYB < 2 
COMMON  TOPSOI C 33  y 6 ) y VEGETA ( 10  y 6 ) 

C 

C CATEGORY  RESPONSES 

C 

COMMON  RANIMAC3) yRCLIMA(2) yRGENBE(3) yRGRUHY(5) 

COMMON  ROVRBD  < 7 y 1 0 ) y RSOCEC  < 6 ) y RSUBSO ( 8 ) y RSURH Y < 6 ) 

COMMON  RT0PS0(9) yRVE6ET(2) 

C 

C KEASIyTECONyOPUSE  SUBSYSTEM  PARAMETERS 

C 

COMMON  CAAFIM  y CABAH  y CABFN  ( 3 ) y CABFP  < 3 ) y CABHM 
COMMON  CABS  ( 2 ) y CAC  y CACP  y CADE  y CADF-1 
COMMON  CADS  y CAE  At"  y CAHSAF  y CAHSTS  y CA I P 
' COMMON  CAR3FCyCASFyCASNCyCStESyCSTRM 

COMMON  CSTRP  y FA VG ( 5 ) y PFSTSP  y PF  AC  y RCLTEC  < 29  y 34 ) 

COMMON  TCAR(5) y THICK < 10) y THKTS y TTL < 40 ) 

C 

INTEGER  EXI T y CLMA  y GDES  y GWH Y y OVBD  y SBSL 
INTEGER  SCEC  y SWHY  y TPSL  y VGTA  y ANI M 
INI  EGER  CLIMAT  y GENDES  y GRWHYD  y OVRBDN 
INTEGER  SOCECN  y SUBSOI y SURHYD  y TOPSOI 
INTEGER  VEGETAyANIMAL 

INTEGER  RCLIMA  y RGENDE  y RGRWHY  y ROVRBD y RSOCEC 
INTEGER  RSUBSO  y RSURHY  y RTOPSO  y RVEGET  y RAN I MA 
INTEGER  RCLTEC y TTL 
C 

INTEGER  COMMON  \l) 

EQUIVALENCE  (COMMON  (l)y  ITEK  <D) 

EQUIVALENCE  (lARRY  (l)y  LUT) 

EQUIVALENCE  (IARY2  (l)y  ISTRK) 

EQUIVALENCE  (1ARY2  <2)y  ISECT) 

EQUIVALENCE  (IARY2  (3)y  ICODE) 

EQUIVALENCE  (IARY2  <4)y  LEN) 

C 

LOGICAL  LER 
C 

DIMENSION  EK0N<5) y 1FLCK(6) 

DIMENSION  10RDER(29) y EXPENS (29) 

DIMENSION  CARHL  (10) y INHERE  (10) 

C 

C 
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0111 

0112 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120 

0121 

0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 

0161 

0162 

0163 

0164 

0165 

0166 


C SET  CONVERSION  FACTORS 

C 


CFl  = 

435 

60*  / (27* 

t 100*) 

CF2  = 

CFl 

t 2* 

CF3  = 

435 

60*  / (12* 

t 27  * t 

CHECK 

FOR 

FLAGS  AND 

Ot'S 

4 

DO  5 

1 = 

1,  6 

cr 

%J 

IFLCK 

(1) 

= 0 

CALL  TCONO  (IFLCK) 

C 

C INITIALIZE  INCREMENTS  AMD  SET  UP  THE  LOOP 

C 

LUO  = 0 
10  II  = 0 
IC2  = 0 

DO  8 I = 1»  NU 
8 CARHL  (I)  = 0* 

I CHECK  = 0 
DO  15  I = 1>  29 
15  EXPENS  (I)  = 0* 

IF  (IPNTR  *EQ*  2)  GOTO  50 
LUO  = LUO  + 1 
IPTRO  = 0 

IF  <LUO  *GT*  5)  GOTO  600 
C 

C CHECK  IFLCK  ARRAY  AND  GCPA  ARRAY  FOR  Ot'S 

C 

GOTO  <20,  25,  30,  35,  40)  LUO 
C 

C CROPLAND  t CHECK  CONDITIONS  1,2, 3, 4,  AND  7 

C 


20 

IF 

(GCPA  (1) 

♦EQ*  0*) 

500, 

oo 

jUm  Am 

oo 

Am  Am 

DO 

23  I = 1, 

4 

IF 

(IFLCK  (I) 

♦EQ*  1) 

500, 

23 

23  CONTINUE 
GOTO  50 


C 

C NAfIVE  VEGETATION  t CHECK  CONDITIONS  4,5,  AND  7 

C 

25  IF  (IFLCK  (4)  ♦ECK  1 ♦OR*  IFLCK  (5)  *EQ*  1)  500 

26  IF  (GCPA  (2)  ♦EQ*  0*)  500,  50 

C 

C WILDLIFE  t CHECK  CONDITIONS  3,5,  AND  7 

C 

30  IF  (IFLCK  (3)  ♦EQ*  1 ♦OR*  IFLCK  (5)  *EQ*  1)  500 

31  IF  (GCPA  (3)  *EQ*  0*)  500,  50 

C 

C WATER  RECREATION  t CHECK  CONDITIONS  3,4,5,  AND 

C 

35  IF  (GCPA  (4)  *EQ*  0*)  500,  36 

36  IF  (IFLCK  (3)  *E0*  1 *0R*  IFLCK  (4)  *EQ*  1 *0R* 

♦ 500,  50 

C 

C HIGH  USE  t CHECK  CONDITIONS  1,3, 4, 5,  AND  7 

C 
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26 


31 


IFLCK  (5)  *EQ*  1) 


0167 

0163 

0169 

0170 

0171 

0172 

0173 

0174 

0175 

0176 

0177 
0173 

0179 

0180 
0181 
0182 

0183 

0184 
0135 
0186 

0187 

0188 
0139 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

0197 

0198 

0199 

0200 
0201 
0202 

0203 

0204 

0205 

0206 

0207 

0208 

0209 

0210 
0211 
0212 

0213 

0214 

0215 

0216 

0217 

0218 

0219 

0220 
0221 
0222 


40 

IF 

(GCPA  ( 

5)  ♦EQ* 

0*)  500? 

45 

45 

DO 

47  I = 

1,  5 

IF 

(I  *EQ* 

2)  GOTO 

47 

IF 

(IFLCK 

(I)  *EQ* 

1)  500? 

47 

47 

CONTINUE 

TOPSOIL? 

SUBSOIL 

NANAGENENT  AND  OVERBURDEN  PREPARATION 

z:  z;  s: : 

===== 

II 

II 

it 

II 

II 

II 

II 

II 

II 

1! 

II 

II 

II 

II 

II 

II 

II 

II 

II 

II 

II 

II 

II 

u 

II 

ji 

il 

II 

II 

II 

II 

II 

II 

II 

II 

I! 

II 

ii 

II 

II 

I! 

1! 

Ii 

II 

II 

Ii 

II 

II 

II 

1! 

II 

II 

II 

Ii 

II 

II 

II 

II 

II 

II 

II 

C 

50  CALL  TCONl  (I CHECK) 

IF  (ICHECK  *EQ*  0)  GOTO  100 
CALL  TC0N2  (ICHECK) 

IF  (ICHECK  *EQ*  0)  GOTO  70 
C 

C STRIP  / RESPREAD  TWO  FEET  OF  SUBSOIL  (C3»C4) 


6011=11+1 

lORDER  (II)  = 5 

EXPENS  (II)  = CSTRN  t CF2 

IF  (LUO  *EQ*  1 ♦OR*  LUO  *EQ*  5)  GOTO  65 

EXPENS  (II)  = EXPENS  (II)  - (EXPENS  (II)  t PCEQ19  (LUO-D) 
6511=11+1 

lORDER  (II)  = 6 

EXPENS  (II)  = CSTRP  t CF2 

IF  (LUO  ♦EQ*  1 ♦OR*  LUO  *EQ*  5)  GOTO  80 

EXPENS  (II)  = EXPENS  (II)  - (EXPENS  (II)  t PCEQ19  (LUO-D) 
GOTO  80 


70  1C2  = 1 

80  CALL  TC0N3  ( ICHECK D WHERE » IRIP ) 

IF  (ICHECK  *EQ*  0 *AND*  1C2  *EQ*  1)  GOTO  90 
IF  (ICHECK  *EQ*  0)  GOTO  120 
C 

C REHANDLE  WHOLE  LAYER  (Cl) 

C 

II  = II  + 1 
lORDER  (II)  = 7 
DO  85  I = 1>  NU 

IF  (1 WHERE  (I)  ♦EG*  0)  GOTO  85 
CARHL  (I)  = CStES  t THICK  (IWHERE  (I))  t CFl 
85  EXPENS  (II)  = EXPENS  (II)  + CARHL  (I) 

IF  (IC2  *NE  *1)  GOTO  120 
C 

C REHANDLE  2 FEET  OF  SEEDBED  SUITABLE  SPOIL  (C2) 

r« 

w 

90  II  = II  + 1 

lORDER  (II)  = 8 
EXPENS  (II)  = CSTES  t CFl 
GOTO  120 
C 

C STRIP  / RESPREAD  ALL  TOPSOIL  (A1>A2) 

C 

100  II  =11+1 

lOFsDER  (II)  = 1 

EXPENS  (II)  = CSTRN  t THKTS  t CF3 
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0223 

0224 

0225 

0226 
0227 
0^2S 

0229 

0230 

0231 

0232 

0233 

0234 

0235 

0236 

0237 

0238 

0239 

0240 

0241 

0242 

0243 

0244 

0245 

0246 

0247 

0248 

0249 

0250 

0251 

0252 

0253 

0254 


0256 

0257 

0258 

0259 

0260 
0261 
0262 

0263 

0264 

0265 

0266 

0267 

0268 

0269 

0270 

0271 

0272 

0273 

0274 

0275 

0276 

0277 

0278 


IF  (LUO  ♦LQ*  1 ♦OR*  LUO  5)  GOTO  105 

EXPENS  (II)  = EXPENS  (II)  - (EXPENS  (II)  t PCEQ19  (LUO-D) 

105  11=11+1 

lORDEP  (II)  = 2 

EXPENS  (II)  = GSTRP  t THKTS  t OF 3 
II  (LUO  *EG*  1 *0F!*  LUO  *EQ*  5)  GOTO  110 

EXPENS  (11)  = EXPENS  (II)  - (EXPENS  (II)  t PCEQ19  (LUO~D) 

C 

C CHECK  TOPSOIL  THICKNESS 

C 

110  IF  (RTOPSO  (1)  *EQ*  4)  GOTO  80 
C 

CALL  TC0N4  (ICHECK) 

IF  (ICHECK  *E0*  0)  GOTO  111 
II  = II  - 2 
GOTO  60 
C 

C STRIP  / RESPREAD  ONE  FOOT  OF  SUBSOIL  (BlyB2) 

C 

111  II  = II  + 1 

lORDER  (II)  = 3 

EXPENS  (II)  = CSTRM  t CFl 

IF  (LUO  *EQ«  1 *0R*  LUO  ♦EQ*  5)  GOTO  115 

EXPENS  (II)  = EXPENS  (II)  - (EXPENS  (II)  PCEQ19  (LUO-D) 

115  II  = II  + 1 

I ORDER  (II)  = 4 

EXPENS  (II)  = CSTRP  t CFl 

IF  (LUO  *EQ*  1 ♦OR*  LUO  *EQ*  5)  GOTO  80 

EXPENS  (II)  = EXPENS  (II)  - (EXPENS  (II)  t PCEQ19  (LUO-D) 

GOTO  80 
C 

C GRADE  SPOIL  (C3) 

C 

120  II  = II  + 1 

lORDER  (ID  = 9 

EXPENS  (II)  = GCPA  (LUO) 

IF  (LUO  *EQ*  5 ♦OR*  IRIP  *EQ*  0)  GOTO  130 
C 

C RIP  3 FOOT  CENTERS  (C4) 

C 

II  = II  + 1 

lORDER  (ID  = 10 
EXPENS  (ID  = CAR3FC 
IF  (LUO  *EQ*  1)  GOTO  130 

EXPENS  (ID  = EXPENS  (ID  - (EXPENS  (II)  t PCEQ19  (LUO-D  ) 

C 

C SEEDBED  PREPARATION 

C =====:=:=====:===n===::=:=:=.====  = ===:=====:  = =n=====================:=========:=.===r===========::===::=====.  = = =====:==  = r:==  = =====:r:^ 

c 

C CHISEL  PLOW 

C 

130  II  = II  + 1 

lORDER  (II)  = 11 
EXPENS  (II)  = CACP 

IF  (LUO  *EQ*  1 *0R.  LUO  *EQ*  5)  GOTO  140 
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0279 

EXPENS  (11)  = EXPENS  (II)  - (EXPENS 

(II) 

* 

PCEQ19  (LUO-1 )) 

0280 

140 

ACACP  = EXPENS  (11) 

0281 

C 

0282 

C 

DISC  AND  HARROW  (D2) 

0283 

C 

0284 

II  =11+1 

0285 

lORBER  (II)  = 12 

0286 

EXPENS  (II)  = CADH 

0287 

IF  (LUO  ♦EQ*  1 ♦OR*  LUO  *EQ*  5)  GOTO 

150 

0288 

EXPENS  (II)  = EXPENS  (II)  - (EXPENS 

(11) 

PCEQ19  (LUO-1 )) 

0289 

150 

ACADH  = EXPENS  (II) 

0290 

C 

0291 

C 

CHAINING  (D3) 

0292 

C 

0293 

II  = II  + 1 

0294 

lORDER  (II)  = 13 

0295 

EXPENS  (II)  = CAC  t PCEQ19  (LUO  - 1) 

0296 

IF  (EXPENS(II)  *GT*  0*)  GOTO  151 

0297 

II  = II  - 1 

0298 

C 

0299 

C 

0300 

C 

SEEDING 

0301 

C 

0302 

C 

0303 

C 

0304 

C 

BUY  SEED  (El) 

0305 

C 

0306 

151 

II  = II  + 1 

0307 

lORDER  (II)  = 14 

0308 

IF  (LUO  *EQ*  1)  GOTO  155 

0309 

EXPENS  (11)  = CABS  (2)  - CABS  (2)  ^ \ 

PCEQ19 

(LUO  - 1) 

0310 

> + CABS  <2)  t 2.  t PCEQ19 

(LUO 

— 

1) 

0311 

GOTO  160 

0312 

155 

EXPENS  (11)  = CABS  (1) 

0313 

160 

ACABS  = EXPENS  (II) 

0314 

C 

0315 

C 

DRILL  SEED  (E2) 

0316 

C 

0317 

II  =11+1 

0318 

lORDER  (II)  = 15 

0319 

EXPENS  (II)  = CADS 

0320 

IF  (LUO  ♦EQ»  1 *0R*  LUO  *EQ*  5)  GOTO 

170 

0321 

EXPENS  (II)  = EXPENS  (11)  - (EXPENS 

(II) 

t 

PCEQ19  (LUO-1 )) 

0322 

170 

ACADS  = EXPENS  (II) 

0323 

c 

0324 

c 

BUY  FERTILIZER  : NITROGEN  (E3A) 

0325 

c 

0326 

II  =11+1 

0327 

lORDER  (II)  = 16 

0328 

EXPENS  (II)  = CABFN  (RTOPSO  (8)) 

0329 

c 

0330 

c 

BUY  FERTILIZER  : PHOSPHATE  (E3B) 

0331 

c 

A 7 7 0 

II  = II  + 1 

0333 

lORDER  (II)  = 17 

0334 

EXPENS  (II)  = CABFP  (RTOPSO  (9)) 

* 
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DFs’lLL  FERTILIZER  (E4) 


0335 

0336 

0337 

0338 

0339 

0340 

0341 

0342 

0343 

0344 

0345 

0346 

0347 

0348 

0349 

0350 

0351 

0352 

0353 

0354 

0355 

0356 

0357 

0358 

0359 

0360 

0361 

0362 

0363 

0364 

0365 

0366 

0367 

0368 

0369 

0370 

0371 

0372 

0373 

0374 

0375 

0376 

0377 

0378 

0379 

0380 

0381 

0382 

0383 

0384 

0385 

0386 

0387 

0388 

0389 

0390 


C 
C 
C 

II  = II  + 1 
lORDER  (II)  = 18 
EXPENS  (II)  = CADF 
IF  (LUO  *EQ*  1 ♦OR*  LUO  »EQ. 
EXPENS  (11)  = EXPENS  (II)  - 
180  ACADF  = EXPENS  (II) 

C 

C BUY  HAY  MULCH  (E5) 

C 

II  = 11  + 1 

lORDER  (II)  = 19 

EXPENS  (II)  = CABHM 

IF  (LUO  ♦EQ*  1 *0R*  LUO  *EQ. 

EXPENS  (II)  = EXPENS  (11) 

190  ACABHM  = EXPENS  (II) 

C 

C APPLY  HAY  MULCH  (E6) 

C 

II  = II  + 1 
lORBER  (II)  = 20 
EXPENS  (II)  = CAAHM 
IF  (LUO  *EQ*  1 *0R*  LUO  *EQ* 
EXPENS  (II)  = EXPENS  (II)  - 
200  ACAAHM  = EXPENS  (II) 

C 


C 

210  IF  (LUO  *NE*  1)  GOTO  220 

IF  (RANIMA  (1)  *NE*  5)  GOTO 
220  II  = II  T 1 

lORBER  (II)  =:  22 
EXPENS  (II)  = CAHSTS 
C 


5)  GOTO  180 

(EXPENS  (II)  t PCEQ19  (LUO-1 )) 


5)  GOTO  190 

(EXPENS  (II)  t PCEQ19  (LUO-1 )) 


5)  GOTO  200 

(EXPENS  (II)  t PCEQ19  (LUO-1) ) 


SEEDLINGS 


C PROTECT 

C = = ======  = =:=:==  = ============  = =====:====  = ===:==  = ====  = = 

c 
c 

C BUYt  apply  HERBICIDE  (FI) 

C 

230  IF  (LUO  <EQ*  2 *0R*  LUO  *EQ*  3)  GOTO  234 
II  = II  + 1 
lORDER  (II)  = 23 
EXPENS  (II)  = CABAH 
ACABAH  = EXPENS  (II) 

GOTO  235 


C HYDROMULCH  SEED  AND  FERTILIZER  (E7) 

C 

IF  (LUO  *EQ*  1 *0R*  LUO  *EQ»  5)  GOTO  210 
II  = II  + 1 
lORDER  (II)  = 21 

EXPENS  (II)  = CAHSAF  t PCEQ19  (LUO  - 1) 

C 

C HAND  PLANT  SHRUB  AND  TREE  SEEDLINGS 


230 
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0391 

0392 

0393 


234  ACABAH  = 0* 


0394 


0395 


0396 

0397 
0393 

0399 

0400 

0401 

0402 

0403 

0404 

0405 

0406 

0407 

0408 

0409 

0410 


0442 


044: 


0444 


0445 


0446 


C 

C 

C 


tRECT  ANIMAL  FENCING  <F2) 


235  IF  (LUO  *EQ*  2)  236,  237 

236  IF  (ROEGET  (1)  ♦EQ*  4)  239,  237 

237  IF  (RANIMA  (1)  .EQ*  1 ♦OR*  RSOCEC  (1)  *EQ*  1 
& *0R*  RANIMA  (2)  *EQ*  1)  239,  240 

239  II  = II  + 1 

1 ORDER  (ID  = 24 
EXPENS  (II)  = CAEAF 


C 

C CLIMATE  MANAGEMENT 

c 

C 1 

C SNOW  FENCING  (Gl) 

C 


240  1 CHECK  = 0 


0411 

IF  (RCLIMA 

(2)  *EQ*  4) 

I CHECK 

= 

1 

0412 

IF  (LUO  *6T 

♦ 2 *AND*  RCLIMA  ( 

2) 

♦ EG* 

0413 

IF  (I CHECK 

♦EQ*  0)  GOTO 

250 

0414 

II  = II  + 1 

0415 

I ORDER  (11) 

= 25 

0416 

EXPENS  (II) 

= CASE 

0417 

IF  (LUO  *£0 

♦ 1 *0R*  LUO 

♦ EG* 

4) 

GOTO 

0418 

0419 

O 

O 

c 

SEED  NURSE 

CROP  (G2) 

0420 

0421 

c 

II  = II  + 1 

0422 

ICRDER  (11) 

— 0 7 

— 

0423 

EXPENS  (11) 

= CASNC 

r' 

Cr 

IRRIGATE  PL 

ANTINGS  (G3) 

0426 

o 

w 

0427 

w:.uj  V 

CALL  ICONS 

(I CHECK) 

0420 

IF  (I CHECK 

♦EG*  0)  GOTO 

260 

0429 

II  = II  + 1 

0430 

lORDER  (II) 

= 27 

0431 

EXPENS  (11) 

= CAIP 

0432 

IF  (LUO  *EQ 

♦ 1 *0R*  LUO 

♦ EG* 

5) 

GOTO 

0433 

EXPENS  (11) 

= EXPENS  (II)  - 

(EXPENS 

0434 

c 

0435 

c 

0436 

c 

STABILIZE 

TOPSOIL 

0437 

0438 

c 

c 

zr  rn : 

ii 

il 

ii 

i! 

i! 

II 

il 

Ii 

ii 

ii 

ii 

II 

II 

II 

II 

II 

II 

II 

II 

II 

II 

II 

II 

II 

= — — 

zz  zz 

zz  zz  zz  zz  zz  t 

0439 

260 

II  = II  + 1 

0440 

lORDER  (11) 

= 28 

0441 

EXPENS  (II) 

= (ACACP  4- 

ACADH 

+ 

ACABS 

= 1 


> 


CABFN  (RTOPSO  (8))  + CABFP  (RTOPSO  (9)) 
ACADF  + ACABHM  + ACAAHM  + ACABAH)  t 
(PFSTSP  / 100*) 


C 

C 
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0447 

0448 

0449 

0450 

0451 

0452 

0453 

0454 

0455 

0456 

0457 

0458 

0459 

0460 

0461 

0462 

0463 

0464 

0465 

0466 

0467 

0468 

0469 

0470 

0471 

0472 

0473 

0474 

0475 

0476 

0477 

0478 

0479 

0480 

0481 

0482 

0483 

0484 

0485 

0486 

0487 

0488 

0489 

0490 

0491 

0492 

0493 

0494 

0495 

0496 

0497 

0498 

0499 

0500 

0501 

0502 


C 


AllMI^aSTRATION  COSTS 


270 


C 

C 

C 


280 

C 

C 

C 

500 

C 

C 

C 

600 


N = II 
II  =11+1 
I ORDER  (II)  = 29 
TOTAL  = 0* 

DO  270  I = 1j  N 

TOTAL  = TOTAL  + EXPENS  (I) 

EXPENS  (II)  = TOTAL  t PFAC  / 100* 

TOTAL  COST 

TCAR  (LUO)  = 0* 

DO  280  J=lr  II 

TCAR  (LUO)  = TCAR  (LUO)  + EXPENS  (J) 
IP  (IPNTR  ♦EQ*  2)  700>  10 


Ot  EXISTS  FOR  THIS  LUO*  SET  TCAR  TO  ZERO  AND  BRANCH  TO  10 

TCAR  (LUO)  =0* 

GOTO  10 

ARRANGE  FOR  PRINTOUT  IN  INCREASING  ORDER  (DONE  FOR  OPUSE  RUN) 

IF  (IPNTR  *EQ*  3)  RETURN 
IF  (LER)  CALL  ERASE 
IF  (LER)  CALL  HOME 


IPNTR  = 2 
DO  610  I = 1>  5 
610  EKON  (I)  = TCAR  (I) 

JJ  = 1 

612  EMIN  = AMINl  (EKON  (1),  EKON  (2)»  EKON  (3)»  EKON  (4)»  EKON  (5)) 
DO  615  LUO  = ly  5 

IF  (EKON  (LUO)  *EQ*  EMIN)  620?  615 

615  CONTINUE 
C 

C PRINT  OUT  MESSAGE(S)  FOR  0:^c 

C 


620 

IF  (LUL  *EQ 
WRITE  (LUL? 

♦ LUT) 
1000) 

GOTO  622 

622 

GOTO  (625? 

630  y 6 

35?  640?  645) 

625 

WRITE  (LUL? 
GOTO  650 

2000) 

CTL 

630 

WRITE  (LUL? 
GOTO  650 

2100) 

TTL 

635 

WRITE  (LUL? 
GOTO  650 

2200) 

TTL 

640 

WRITE  (LUL? 
GOTO  650 

2300) 

TTL 

645 

WRITE  (LUL? 

2400) 

TTL 

650  IF  (EKON  (LUO)  *GT*  0*)  GOTO  10 


WRITE  (LUL?  3200) 


GOTO  (655?  660?  663?  665?  670)  LUO 
655  IF  (IFLCK  (1)  *EQ*  1)  U'RITE  (LUL?  4100) 
IF  (IFLCK  (2)  *EQ*  1)  WRITE  (LUL?  4000) 
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0503 

IF 

(IFLCK 

(3) 

♦EQ.  1) 

WRITE 

(LULy 

4200) 

0504 

IF 

(IFLCK 

(4) 

♦EQ.  1) 

WRITE 

(LULy 

5002) 

0505 

IF 

(GCPA 

(1) 

♦EQ.  0.) 

WRITE 

(LULy 

4500) 

0506 

GOTO  680 

0507 

660 

IF 

(GCPA 

(2) 

.EQ.  0) 

WRITE 

(LULy 

4500) 

0508 

IF 

(IFLCK 

(4) 

♦EQ.  1) 

WRITE 

(LULy 

5002) 

0509 

IF 

(IFLCK 

(5) 

♦EQ.  1) 

WRITE 

(LULy 

5003) 

0510 

GOTO  680 

0511 

663 

IF 

(GCPA 

(3) 

♦EQ.  0.) 

WRITE 

(LULy 

4500) 

0512 

IF 

(IFLCK 

(3) 

♦EQ.  1) 

WRITE- 

(LULy 

5001 ) 

0513 

IF 

(IFLCK 

(5) 

♦EQ.  1) 

WRITE 

(LULy 

5003) 

0514 

GOTO  680 

0515 

665 

IF 

(IFLCK 

(5) 

♦EQ.  1) 

WRITE 

(LULy 

4400) 

0516 

IF 

(IFLCK 

(3) 

♦EQ.  1) 

WRITE 

(LULy 

5001) 

0517 

IF 

(IFLCK 

(4) 

♦EQ.  1) 

WRITE 

(LULy 

5002) 

0518 

IF 

(GCPA 

(4) 

♦EQ.  0.) 

WRITE 

(LULy 

4500) 

0519 

GOTO  680 

0520 

670 

IF 

(IFLCK 

(1) 

♦EQ.  1) 

WRITE- 

(LULy 

4100) 

0521 

IF 

(IFLCK 

(2) 

.EQ.  1) 

WRITE 

(LULy 

4000) 

0522 

IF 

(IFLCK 

(3) 

♦EQ.  1) 

WRITE 

(LULy 

4200) 

0523 

IF 

(IFLCK 

(4) 

♦EQ.  1) 

WRITE 

(LULy 

4300) 

0524 

IF 

(IFLCK 

(5) 

♦EQ.  1) 

WRITE 

(LULy 

4400) 

0525 

IF 

(GCPA 

(5) 

♦EQ.  0.) 

WRITE 

(LULy 

4500) 

0526 

C 

0527 

C 

RESET  EKON  AND  GET  THE  NEXT 

LUO 

0528 

C 

0529 

680 

IF 

( .NOT. 

LER 

♦OR.  LUL 

♦NE.LUT)  GOTO  690 

0530  CALL  BELL 

0531  CALL  TINPT  (IANS) 

0532  CALL  ERASE 

0533  CALL  HOME 

0534  690  EKON  (LUO)  = 999999. 

0535  JJ  = JJ  + 1 

0536  IF  (JJ  .GT*  5)  RETURN 

0537  GOTO  612 

0538  C 

0539  C WRITE  OUT  THE  TECHNIQUES  LIST  AND  CHECK  FOR  FLAGS 


0540 

0541 

0542 

0543 

0544 

0545 

0546 

0547 

0548 

0549 

0550 

0551 

0552 

0553 

0554 

0555 

0556 

0557 

0558 


C 

700  WRITE  (LUL?  3001) 

711  DO  715  1 = 1,  II 

IF  (lORDER  (I)  7)  GOTO  712 

WRITE  (LULf3100)  ly  (RCLTEC  (lORDER  ( I ) y K ) y K=1 y 20 ) y EXPENS  (1) 
GOTO  715 

712  DO  714  L = ly  NU 

IF  (1 WHERE  (L)  .EQ.  0)  GOTO  714  . 

WRITE  (LULy  3102)  (RCLTEC  ( lORDER ( I ) y K ) y K = lyl4)y 
> I WHERE  (L)y  CARHL  (L) 

IPTRO  = 1 

714  CONTINUE 

IF  (IPTRO  .EQ.  0)  GOTO  715 

IF  (RGENDE  (1)  .ECU  1)  WRITE  (LULy  3103)  ly  EXPENS  (I) 

715  CONTINUE 

WRITE  (LULy  3151)  TCAR  (LUO) 

6T0TAL  = AREA  (LUO)  t TCAR  (LUO)  / 1000000. 

WRITE  (LULy 3152)  AREA  (LUO)y  GTOTAL 
GOTO  (720y  725y  730y  680y  740)  LUO 
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0559 

720 

IF  (IFLCK  (5)  *EQ* 

1 ) 

WRITE 

(LUL,  5000) 

0560 

GOTO  680 

0561 

725 

IF  (IFLCK  (3)  *EQ* 

1) 

WRITE 

(LUL,  5000) 

0562 

GOTO  680 

0563 

730 

IF  (IFLCK  (4)  *EQ* 

1) 

WRITE 

(LUL,  5000) 

0564 

GOTO  680 

0565 

740 

IF  (IFLCK  (6)  *EQ* 

1) 

WRITE 

(LUL,  5004) 

0566 

GOTO  680 

0567 

C 

0568 

C 

FORMAT  STATEMENTS 

0569 

C 

0570 

1000 

FORMAT  (IHl) 

0571 

C 

0572 

C 

i 

1 

0573 

2000 

FORMAT  ( IX,  40A2 

, 

/,  lOX" 

ttt  CROPLAND  ALTERNATIVE  ttf  /) 

0574 

C 

0575 

2100 

FORMAT  (1X,40A2,  /, 

7X 

•ttt  NATIVE  VEGETATION  ALTERNATIVE 

0576 

/) 

0577 

C 

0578 

2200 

FORMAT  ( IX,  40A2, 

/, 

10X■)fc:^c:^c  WILDLIFE  ALTERNATIVE  ttf  /) 

0579 

C 

0580 

2300 

FORMAT  (IX,  40A2,  / 

, 

BX'ttt 

WATER  RECREATION  ALTERNATIVE  )*c:^c)t:"/) 

0581 

C 

• 

0582 

2400 

FORMAT  ( IX,  40A2, 

/, 

lOX^ttt  HIGH  USE  ALTERNATIVE  /) 

0583 

0584 

0585 

0586 

0587 

0588 

0589 

0590 

0591 

0592 

0593 

0594 

0595 

0596 

0597 

0598 

0599 

0600 
0601 
0602 

0603 

0604 

0605 

0606 

0607 

0608 

0609 

0610 
0611 
0612 

0613 

0614 


C 


C 


C 

C 

C 

C 

C 


3001  FORMAT  < 15X'TECHNIQUE'21X'C0ST/ACREVy  15X>  9 (■-•')» 
t21Xy  9 

3102  FORMAT  (2X'>  " , 14A2 » 12 > 1 IX “ # ‘ F8 « 2 ) 

3103  FORMAT  (IX? 12*)  TOTAL  REHANDLE  COST  IS  "F8^2“  DOLLARS/ACRE") 

3100  FORMAT  (1X»  12' )%  20A2>  IX,  '$'1X,  F7*2) 

3151  FORMAT  (/,  45X,  9 <'  = '),  /,  37X ' TOTAL ' 3X ' " IX , F8*2/) 

3152  FORMAT  <1X  "GRAND  TOTAL  COST  FOR  'F7^1'  ACRES  IS  'F13*2,1X 
>■ MILLION  DOLLARS') 

3200  FORMAT  (/,  3X ' REGARDLESS  OF  OTHER  ENMIRONMENTAL  CONSIDERATIONS'/, 
)Jc3X' REFLECTED  IN  THE  FEASIBILITY  RANKING,  THE  TECHNIQUES'/, 
)fc3X'LlST  IS  NOT  AOAILADLE  FOR  THIS  ALTERNATIVE  BECAUSE  J"/) 

4000  FORMAT  < VX’tt  THE  AVERAGE  SLOPE  OF  THE  AREA  EXCEEDS  THE'/, 
t 7X"  MAXIMUM  (5<7  DEG/8  PERCENT)  REQUIRED  TOV, 

t 7X'  FEASIBLY  RECLAIM  TO  THIS  ALTERNATIVE*'/) 

4100  FORMAT  (.7X^tt  THE  HIGHUALL  AND  SPOIL  PILE  ASSOCIATED  WITH'/, 
t 7X"  THIS  BOX  CUT  CANNOT  BE  GRADED  TO  THE'/, 

t 7X"  MAXIMUM  SLOPE  (5*7  DEGREES/8  PERCENT)  REQUIRED'/, 

t 7X'  TO  FEASIBLY  RECLAIM  TO  THIS  ALTERNATIVE*'/) 

k 

4200  FORMAT  (7X‘tt  THIS  LAND  USE  OPTION  IS  NOT  COMPATIBLE  WITH'/, 
t 7X"  THE  PRESENCE  OF  THREATENED  OR  ENDANGERED'/, 
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0615 

0616 

0617 

0618 

0619 

0620 

0621 

0622 

0623 

0624 

0625 

0626 

0627 

0628 

0629 

0630 

0631 

0632 

0633 

0634 

0635 

0636 

0637 

0638 

0639 

0640 

0641 

0642 

0643 

0644 

0645 

0646 

0647 


* 

C 

4300  FORMAT 
t 
t 
C 

4400  FORMAT 
# 

C 

4500  FORMAT 
t 
C 
C 

5000  FORMAT 
t 

C 

5001  FORMAT 
t 

t 

C 

5002  FORMAT 
t / 

C 

5003  FORMAT 
t 

t 


7X"  PLANT  SPFCIES**/) 

<7X")^^*  THIS  LAND  USE  OPTION  IS  NOT  COMPATABLE  WITHV? 
7X"  THE  PRESENCE  OF  THREATENED  OR  ENDANGERED “/ y 
7X"  ANIMAL  SPECIES* “/) 


THIS  LAND  USE  OPTION  IS  NOT  COMPATABLE  WITH"/y 
7X*  PRIME  AGRICULTURAL  LAND‘/) 

GRADING  COSTS  HAUE  NOT  BEEN  COMPUTED  FOR'/y 
7X"  THIS  ALTERNATIVE"/) 


(/y  5X":*c*  PRESENT  LAWS  INDICATE  THAT  YOU  MUST  RECLAIM"/y 
5X"  TO  THIS  LAND  USE  OPTION"/) 

</y  5X"5fC3«c  THIS  LAND  USE  OPTION  MAY  BE  COMPATABLE " /y 

5X"  WITH  THE  PRESENCE  OF  THREATENED  OR  ENDANGERED "/ y 
5X"  PLANT  SPEClESy  BUT  AS  A SECONDARY  USE  ONLY") 

(/y  ^X^tt  THIS  LAND  USE  OPTION  MAY  BE  COMPATABLE  WITH" 

5X“  THE  PRESENCE  OF  THREATENED  OR  ENDANGERED "/ y 
5X"  ANIMAL  SPEClESy  BUT  AS  A SECONDARY  USE  ONLY") 

</y  5X")fc}fc  THIS  LAND  USE  OPTION  MAY  BE  COMPATABLE  WITH"/y 
5X"  PRIME  AGRICULTURAL  LANDy  BUT  AS  A SECONDARY  USE" 
IX'ONLY") 


C 

5004  FORMAT  </y  5X'tt  THIS  LAND  USE  OPTION  ASSUMES  THAT  THE"/y 
)fc5X"  ALLUVIAL  VALLEY  FLOOR  CAN  BE  LEGALLY  ELIMINATED  * " / ) 
C 

END 

END$ 


N 
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STFCn 

0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 

0011 

0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 

0021 

0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

003/ 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 

0053 

0054 


1=00004  IS  ON  CR00015  USING  00035  BLKS  R=0236 


FTN4 

SUBROUTINE  TFCD 

Q -fEST  FOR  COMPLETE  DATA 

C 

C LEVEL  1 
C 

C TFCD  IS  ACCESSED  BY  CLAIM  TO  REPORT  THE  STATUS  OF  THE  CURRENT 
C DATA  SET*  IF  THE  DATA  ARE  INCOMPLETE^  TFCD  REPORTS  THE  LOCATION 
C OF  THE  NEXT  DATA  ITEM  TO  BE  ENTERED?  AND  OFFERS  THE  USER  THE 
C OPTION  OF  COMPLETING  DATA  ENTRIES*  (ACTUAL  COMPLETION  OF  DATA 
C INPUT  IS  NOT  HANDLED  IN  THIS  ROUTINE)*  THE  METHOD  IS  TO  SEARCH 
C FOR  THE  FIRST  "ZERO'  RESPONSE  VALUE* 

C 

C ON  ENTRY?  "IPNTR"  IS  USED  AS  FOLLOWS  J 
C IPNTR-1*  TEST  THE  GENERAL  DESCRIPTION 

C IPNTR=2*  TEST  THE  ENVIRONMENTAL  FEASIBILITY  CATEGORIES 

C 1PNTR=3*  TEST  THE  ENTIRE  DATA  SET 

C 

C ON  RETURN?  "lOPTN"  IS  USED  AS  FOLLOWS  J 
C I0PTN=0*  DATA  IS  COMPLETE 

C I0PTN=1*  DATA  IS  INCOMPLETE?  BUT  THE  USER  WANTS  TO  FINISH 

C DATA  ENTRIES* 

C I0PTN=2*  DATA  IS  INCOMPLETE?  AND  THE  USER  DOES  NOT  WISH 

C TO  COMPLEIE  DATA  ENTRIES* 

C 

C IF  "IPNTR"  IS  3 ON  ENTRY?  AND  THE  GENERAL  DESCRIPTION  CATEGORY 
C RESPONSES  ARE  INCOMPLETE?  IPNTR  IS  SEI  TO  1 BEFORE  TERMINATION* 

C 

C THE  STATUS  OF  THE  SPOILS  GRADING  PARAMETERS  IS  REPORTED  FOR 
C IPNIR  = 1 OR  3?  BUT  NO  ACTION  IS  TAKEN  IF  ALL  LAND  USE  OPTIONS 
C ARE  NOT  DEFINED*  IF  GENERAL  DESCRIPTION  CATEGORY  RESPONSES  ARE 
C INCOMPLETE?  THE  STATUS  OF  THE  SPOILS  GRADING  DATA  IS  NOT  REPORTED 
C 

C "EXIT"  IS  SET  TO  THE  NEXT  CATEGORY  NUMBER  REQUIRING  INPUT 
C "LEXIT"  IS  SET  TO  THE  NEXT  HEADING  NUMBER  REQUIRING  INPUT 
C 
C 

C THE  CALLING  SEQUENCE  IS  I CALL  TFCD 

C 

C TFCD  USES  THE  TCS  ROUTINES  : EELL?ERASE?HOME?  AND  TINPT* 

C 

C "ICHAR"  IS  THE  TINPT  RETURN  CELL* 

C 

C TFCD  DECLARES  LABEL  COMMON  "ALTRN"  AND  LABEL  COMMON  "TABLE"* 

C 

C THIS  ROUTINE  WAS  WRITTEN  BY  GREEN 
C 

C CLAIM  RELEASE  1*0  ~ APRIL  1?  1980 

C 

C 

C TEKTRONIX  COMMON 

C 

COMMON  ITEK  (45) 
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0055  C 

0056  C 

0057  C 

0058 

0059  C 

0060  C 

0061  C 

0062 

0063 

0064 

0065 

0066 

0067 

0068  C 

0069  C 

0070  C 

0071 

0072 

0073 

0074  C 

0075  C 

0076  C 

0077 

0078 

0079 

0080  C 

0081  C 

0082  C 

0083 

0084 

0085 

0086  C 

0087  C 

0088  C 

0089 

0090 

0091 

0092  C 

0093  C 

0094  C 

0095 

0096 

0097 

0098 

0099 

0100 

0101  C 

0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110  C 


LOGICAL  UNITS  AND  COHfiON  LOCATION 
COMMON  I ARR Y < 5 ) > I AR Y2 ( 5 ) > LER » LUF , LUL 
POINTERS 

COMMON  EXIT  » 1 ANM ( 3 ) y ICLI ( 2 ) » IGEN ( 3 ) » IGRW ( 5 ) 

COMMON  lOPTN  > lOOR ( 7 ) > IPNT R » ISOC < 6 ) , ISUD < 8 ) 

COMMON  ISUR<6) » IT0P(9) ? lOEG < 2 ) y LEXIT  »LUO 
COMMON  MODE  ^NANM  »NCL1  >NGEN  >NGRW 

COMMON  NOOR  jNSECTS  jNSOC  jNSUB  >NSUR 

COMMON  NTOP  » NU  »NOEG 

GRADING  PARAMETERS 

COMMON  ARE A < 5 ) ? BENLEN ( 5 ? 1 0 ) j BENUI ( 5 ? 1 0 ) » COGO » GCP A ( 5 ) 

COMMON  GRDOBS (5) y HWHT (5yl0>y HWSL 1 ( 5 ? 1 0 ) y NSPP <5)y PCEQ 1 9(4) 
COMMON  PERCNT<5> 10) yREHCPY<5) f REH00L<5) »SL0PE(5» 10) >WBP 

CATEGORY  TEXT 

COMMON  ANIM(23y 13) jCLMA(13>13) jGDES(15t13) ,GWHY(22j13) 
COMMON  00DD(11»13) >SBSL(13) j SCEC < 33 y 13 ) t SUHY ( 44 j 13 ) 

COMMON  TPSL ( 49  ? 1 3 ) j VGT A ( 1 5 ? 1 3 ) 

EXPECTATION  VALUES 

COMMON  ANIMAL<13»6) jCLIMAT(8»6) jGENDES<8»6) jGRUHYD<19>6) 
COMMON  0VRBDN<2Sf6) j SOCECN ( 29 j 6 ) f SUBSOI ( 30 y 6 ) , SURHYD ( 23 y 6 ) 
COMMON  T0PS0I(33y6) »VEGETA<10?6) 

CATEGORY  RESPONSES 

COMMON  RANIMA<3) y RCLIMA ( 2 ) » RGENDE< 3 ) ? RGRUHY C 5 ) 

COMMON  ROVRBD  < 7 y 10 ) y RSOCEC ( 6 ) y RSUDSO ( 8 ) y RSURHY  < 6 ) 

COMMON  RT0PS0C9) yRVEGET(2) 

FEASIyTECONyOPUSE  SUBSYSTEM  PARAMETERS 

COMMON  CAAHM  y C ABAH  y CABFN ( 3 ) y CABFP  < 3 ) y CABHM 

COMMON  CABS(2) yCACyCACPyCADF yCADH 

COMMON  CADS  y CAE AF  y CAHSAF  y CAHSTS  y CAI P 

COMMON  CAR3FC  y CASF  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y FAV6 ( 5 ) y PFSTSP  y PFAC  y RCLTEC  < 29  y 34 ) 

COMMON  TCAR<5) yTHICK(lO) y THKT S y TTL < 40 ) 

INTEGER  EXI T y CLMA  y GDES  y GWH Y y OVBD  y SDSL 
INTEGER  SCECySWHYy TPSLy VGTAyANIM 
INTEGER  CLIMATyGENDESy GRWHYDyOVRBDN 
INTEGER  SOCECNy SUBSOIy SURHYDy  TOPSOI 
INTEGER  VEGETAyANIMAL 

I NTEGER  RCL I MA  y RGENDE  y RGRWHY  y ROVRBD  y RSOCEC 
INTEGER  RSUDSO  y RSURHY  y RTOPSO  y RVEGET  y RANI MA 
INTEGER  RCLTECyTTL 
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0111 

0112 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120 
0121 
0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 
0161 
0162 

0163 

0164 

0165 

0166 


C 

C 

C 

C 


C 

C 

C 


C 

C 


C 

C 


C 

C 

C 


C 

C 


INTEGER  GOHMON  (1) 

EQUIVALENCE  (COMMON  <!)?  ITEK  <D) 
EQUIVALENCE  (lARRY  (1),  LUT) 
EQUIVALENCE  (IARY2  <1)t  ISTRK) 
EQUIVALENCE  (1ARY2  (2)»  ISECT) 
EQUIVALENCE  (IARY2  <3)>  ICODE) 
EQUIVALENCE  (1ARY2  (4)»  LEN) 

LOGICAL  LER 


C 


COMMON  /ALTRN/  ALTN 
COMMON  /CTIL/  ICAT 

INTEGER  ALTN(6>4)  T ICATdOj  12)  > IHEALK9) 

DATA  IHEAD/2H  Ay2H  B»2H  C»2H  D>2H  E>2H  E>2H  G?2H  H>2H  1/ 


ASSUME  ALL  DATA  IS  ENTERED 

I0PTN=0 

IE (LER)  CALL  ERASE 
IF(LER)  CALL  HOME 

BRANCH  TO  200  IF  WE  ARE  CHEC^aNG  ENVIRONMENTAL 
FEASIBILITY  CATEGORIES  ONLY* 

1F(1PNTR*EQ*2)  GOTO  200 

TEST  GENERAL  DESCRIPTION  CATEGORY  RESPONSES 

EXIT=1 

DO  100  LEXIT=1,NGEN 

IF(R6ENDE(LEX1T) *EQ*0)  GOTO  500 
100  CONTINUE 

GENERAL  DESCRIPTION  RESPONSES  ARE  COMPLETE 
REPORT  STATUS  OF  SPOILS  GRADING  PARAME TERS 

r -I  A r'  ^ /s 

Wf;'ITE(LUTdOOO) 

DC  110  LU0=1,5 

IF(NGPP(LUO) *EQ*0)  GOTO  110 
F(PASS=1 

WRITE(LUr ,1010)  (ALTN(LUO, J) , J=l,4) 

110  CONTINUE 

IF(KPASS*EQ.O)  WRITE(LUT, 1020) 

DONE  WITH  GENERAL  DESCRIPTION  CHECK* 

PROCEED  IF  WE'RE  CHECKING  THE  WHOLE 
SHEBANG,  OTHERWISE,  RETURN 
1F(IPNTR*EQ*3)  GOTO  200 
115  IF(LER)  WR1TE(LUT,1030) 

IF (LER)  CALL  BELL 
IF(LER)  CALL  TINPT(ICHAR) 

IPNTR=1 

RETURN 

ENVIRONMENTAL  FEASIBILITY  CATEGORY  CHECK- 
START  WITH  CLIMATOLOGY 

200  EXIT=2 

DO  210  LEXIT=:1,NCLI 

IF(RCLIMA(LEXIT) *EQ*0)  GOTO  500 
210  CONTINUE 

TOPSOIL 
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0167 

EXIT=3 

0168 

DO  220  LEXIT=1»NT0P 

0169 

IF<RTOPSD<LEXIT) ♦EQ^O)  GOTO  500 

0170 

220 

CONTINUE 

0171 

C 

SUBSOIL 

0172 

EXIT=4 

0173 

DO  230  LEXIT=1,NSUB 

0174 

IF(RSUBSO(LEXIT) *EQ<0)  GOTO  500 

0175 

230 

CONTINUE 

0176 

C 

OOEK-BUPDEN 

0177 

EXIT=5 

0178 

LEXIT=1 

0179 

1F<R00RBD(1 ?1) *EQ*0)  GOTO  500 

0180 

DO  240  LU=1,NU+1 

0181 

IF<ROORBD(lyLU) *ECnO)  GOTO  245 

0182 

DO  235  LEXIT=3,N0MR+1 

0183 

IF(ROORBD(LEXIT-lyLU) ♦EQ*0)  GOTO  500 

0184 

235 

CONTINUE 

0185 

240 

CONTINUE 

0186 

C 

SURFACE  WATER  HYDROLOGY 

0187 

245 

EXIT=6 

0188 

DO  250  LEXIT=1jNSUR 

0189 

IF<RSURHY(LEXIT) *EQ*0)  GOTO  500 

0190 

250 

CONTINUE 

0191 

C 

GROUND  WATER  HYDROLOGY 

0192 

EXIT=7 

0193 

DO  260  LEXIT=1jNGRU 

0194 

IF<RGRWHY(LEXIT) ♦EQ^O)  GOTO  500 

0195 

260 

CONTINUE 

0196 

C 

VEGETATION 

0197 

EXIT=8 

0198 

DO  270  LEXIT=1jNVEG 

0199 

IF(RVEGEf (LEXIT) *ECUO)  GOTO  500 

0200 

270 

CONTINUE 

0201 

C 

ANIMALS 

0202 

DO  280  LEXIT=l»NANM 

0203 

IF<RANIMA<LEXIT) *EQ*0)  GOTO  500 

0204 

280 

CONTINUE 

0205 

C 

SOCIO-ECONOMICS 

0206 

DO  290  LEXIT=lyNSOC 

0207 

IF(RSOCEC^LEXIT) ♦ECUO)  GOTO  500 

0203 

290 

CONTINUE 

0209 

C 

WE  MADE  IT  THROUGH*  THE  DATA  SET  IS 

0210 

C 

THEREFORE  COMPLETE*  SET  lOPTN 

0211 

C 

TO  ZERO  AND  QUIT* 

0212 

10PTN=0 

0213 

IF  (LER)  WRITE  (LUTyl030) 

0214 

IF  (LER)  CALL  BELL 

0215 

IF  (LER)  CALL  TINPT  (I CHAR) 

0216 

RETURN 

0217 

C 

INCOMPLETE  DATA*  DISPLAY  CATEGORY  AND 

0218 

C 

HEADING  NUMBER  OF  NEXT  DATA  ITEM  TO  BE 

0219 

C 

ENTERED  - SEE  IF  USER  WANTS  TO  COMPLET 

0220 

C 

DATA  ENTRIES  - RETURN* 

0221 

500 

WRITE(LUTy 1040)  ( ICAT ( EXIT > J ) ? J= 1 ^ 1 2 ) , IHEAD(LEXIT) 

0222 

510 

READ (LUT> 1050)  IANS 
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0223 

0224 

0225 

0226 

0227 

0228 

0229 

0230 

0231 

0232 

0233 

0234 

0235 

0236 

0237 

0238 

0239 

0240 

0241 


IF(IANS*EQ*1HY  ♦ DR ♦ 1 ANS ♦ EQ ♦ IHN  ) GOTO  520 
WfA*ITt<LUTj  1060)  IANS 
GOTO  510 

520  IF(IANS*EQtlHY)  I0PTN=1 
IFCIANS.EQ^IHN)  I0PTN=2 
IF(EXIT^EQ* 1 ♦ANIU  IPNTR*EQ*3)  GOTO  115 
RETURN 

C FORMAT  STATEMENTS 

1000  F0RMAT(//10X*SP01LS  GRADING  DAIA  HADE  BEEN  ENTERED  FORJV/) 
1010  FORMAT (lOX-THE  “4A2"  LAND  USE  ALTERNATIVE  V) 

1020  FORMAT <1  OX NONE  OF  THE  LAND  USE  ALTERNATIVES  tf) 

1030  F0RMAT(///>5X? "HIT  THE  RETURN  KEY  TO  CONTINUE ♦♦♦._" ) 

1040  F0RMAT(///>5X"CATEG0RY  RESPONSES  ARE  NOT  COMPLETE  STARTING"/ 

> 5X»"AT  "fl2A2>"  HEADING  "A2y//, 

> 5X"D0  YOU  WISH  TO  COMPLETE  DATA  ENTRIES  ? (Y/N) 
1050  F0RMAT(A2) 

1060  F0RMAT(5X> A2"  ??  PLEASE  RE-ENTER  YOUR  ANSWER  -> 

END 

END^ 
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STOPSO  T=00004  IS  UN  CR00015  USING  00056  BLKS  R=0000 


pool  FTN4 

b002  SUBROUTINE  TOPSO 

b003  C FULL  lUSPLAY — CATEGORY  3 / TOPSOIL 

0004  C 

I&005  C LEVEL  2 
b006  C 

0007  C TOPSO  IS  ACCESSED  BY  EIFD  TO  SCHEDULE  INPUTS  AND  EDITS  TO 

1)008  C CATEGORY  RESPONSES?  AND  EDITS  TO  THE  EXPECTATION  OF  SUCCESS 
)009  C VALUES  FOR  CATEGOTY  3 - TOPSOIL?  USING  FULL  DISPLAY 
0010  C 

poll  C THE  CALLING  SEQUENCE  IS  I CALL  TOPSO 

1)012  C 

loi3  C TOPSO  USES  THE  TCS  ROUTINES  : ERASE  AND  HONE 
0014  C 

t015  C THE  LOCAL  VARIABLES  ARE  I 
016  C 
0017  C 
#018  C 
|019  C 
0020  C 
0021  C 
l022  C 
l023  C 
0024  C 

1025  C 
026  C 
0027  C 

i028  C 
029  C 

0030  C TOPSO  IS  SWAPPED  IN  BY  PROGRAM  TOPSX 
0031  C 

|032  C THIS  ROUTINE  WAS  WRITTEN  BY  GREEN 
9o33  C 

0034  C CLAIM  RELEASE  1*0  - APRIL  1?  1980 

1035  C =====  = ==  = = = = = ==  = ==  = = ==  = ==  = = ==  = = = = ==  = ===:=:=====:===:  = = =:=:  = ==========  = ======  = ========== 

036  C 

0037  C TEKTRONIX  COMMON 

1038  C 

039  COMMON  ITEK  (45) 

0040  C 

0041  C LOGICAL  UNITS  AND  COMMON  LOCATION 

■042  C 

l043  COMMON  I ARRY ( 5 ) ? I ARY2 ( 5 ) ? LER ? LUF ? LUL 

0044  C 

K45  C POINTERS 

46  C 

0047  COMMON  EXIT  ? lANM ( 3 ) ? ICLI < 2 ) ? IGEN < 3 ) ? IGRW < 5 ) 

«/48  COMMON  lOPTN  ? lOVR < 7 ) ? IPNTR  ? ISOC < 6 ) ? ISUD ( 8 ) 

)49  COMMON  ISUR(6) ? 1T0P(9) ? IVE6<2) ?LEXIT  ?LUO 

^J050  COMMON  MODE  ?NANM  ?NCLI  ?N6EN  ?NGRW 

K0051  COMMON  NOVR  ?NSECTS  ?NSOC  ?NSUB  ?NSUR 

52  COMMON  NT OP  ?NU  ?NVEG 

53  C 

0054  C GRADING  PARAMETERS 

I 


IANS  ->  ANSWER  CELL 

II  ->  ■!•  INDEX  L <I?J)  3 TO  TOPSOI  ARRAY 

lOLD  ~>  PRE-EDIT  CATEGORY  RESPONSE  VALUE 
LUORN  ->  LAND  USE  OPTION  REFERENCE  NUMBER 

1 ->  CROPLAND 

2 ->  NATIVE  VEGETATION 

3 ->  WILDLIFE 

4 ->  WATER  RECREATION 

5 ->  HIGH  USE 

6 ->  OTHER 

NN  ->  HEADING  NUMBER 
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005t5 

0056 

005/ 

0058 

0059 

0060 

0061 

0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 

0081 

0082 

0083 

0084 

0085 

0086 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 

0101 

0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


C 


C 

C 

C 


C 

C 

C 


C 


C 

C 


c 

c 

c 


c 


c 


c 


c 

c 


COMMON  AREA ( 5 ) , BENLEN ( 5 , 1 0 ) , BENW I ( 5 » 1 0 ) » C060 . GCPA  < 5 ) 

COMMON  6RDMBS ( 5 ) » HWHT  < 5 ? 1 0 ) » HWBL I ( 5 y 1 0 ) > NSPP ( 5 ) » PCEQ 1 9(4) 
COMMON  PERCNT(5> 10) »REHCPY<5) »REH00L(5) ySL0PE<5» 10) tWBP 

CATEGORY  TEXT 

COMMON  ANIM<23» 13) ,CLMA<13j 13) >GBES(15y 13) >GWHY<22, 13) 
COMMON  00BB(11,13),SBSL<13),  8CEC ( 33 » 1 3 ) » SWHY < 44 , 1 3 ) 

COMMON  TPSL(49yl3) j06TA(15>13) 

EXPECTATION  VALUES 

COMMON  ANIMAL<13»6) >CLIMAT<8,6) >6ENDES(8»6) r6RUHYB(19>6) 
COMMON  0VRBDN<28»6) jS0CECN(29,6) ,SUBS0I(30j6) jSURHYLU23,6) 
COMMON  TOPSOl <33r6) jVE6ETA(10,6) 

CATEGORY  RESPONSES 

COMMON  RANIMA<3) jRCLlMA(2) jRGENDE(3) >R6RWHY<5) 

COMMON  R0VRBD(7f 10) » RSOCEC ( 6 ) j RSUBSO ( 8 ) ? RSURHY ( 6 ) 

COMMON  RT0PS0(9) jRVEGET<2) 

FEAS1»TEC0N»0PUSE  subsystem  PARAMETERS 

COMMON  CAAHM  ? CABAH » CABFN ( 3 ) > CABPP ( 3 ) » CAHBM 

COMMON  CABS  < 2 ) y CAC  y C ACP  y CADF  y CADH 

COMMON  CABS  y CAEAF  y CAHSAF  y CAHSTS  y CAIP 

COMMON  CAR3FC  y CASF  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y FAVG ( 5 ) y PFSTSP  y PFAC  y RCLTEC  < 29  y 34 ) 

COMMON  TCAR<5) y THICK< 10) y THKTBy TTL(40) 

INTEGER  EXI T y CLMA  y 6DES  y GWHY  y OVBD  y BBSL 
INT  EGER  SCEC  y SWHY  y TPSL  y VGTA  y ANIM 
INTEGER  CLIMATyGENBESyGRWHYByOVRBDN 
INTEGER  SOCECN  y BUBSOl y BURHYD y TOPSOI 
INTEGER  VEGEI AyANIMAL 

I NTEGER  RCLl  MA  y RGENBE  y RGRk'HY  y ROVRBD  y RSOCEC 
IN  I EGER  RSUBSO  y RSURHY  y RTOPBO  y RVEGET  y RANI MA 
INTEGER  RCLTEC yTTL 

INTEGER  COMMON  <1) 

EQUIVALENCE  (COMMON  <l)y  ITEK  (1)) 

EQUIVALENCE  (lARRY  <l)y  LUT) 

EQUIVALENCE  (IARY2  (l)y  ISTRK) 

EQUIVALENCE  (IARY2  (2)y  ISECT) 

EQUIVALENCE  (IARY2  (3)y  ICODE) 

EQUIVALENCE  (IARY2  (4)y  LEN) 

LOGICAL  LER 

DISPLAY  MODE 

1 IF  <.NOT*LER)  GOTO  5 
CALL  ERASE 
CALL  HOME 

5 GOTO  <10y20y30)  MODE 
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0111 

0112 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120 

0121 

0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 

0161 

0162 

0163 

0164 

0165 

0166 


10  WRITE  (LUT»1010) 

GOTO  40 

20  WRITE  (LOT, 2010) 

GOTO  40 

30  WRITE  <LUT»3010) 

40  IE  ( «0DE*6T*1)  GOTO  50 

GOTO  (100?200j250>300T350j400y450T500j550)  LEXIT 
C USER  INPUT  ->  EDIT  HEADING 

50  WRITE  (LUTy2020) 

51  READ  (LUT»2030)  IANS 


IF 

(IANS*EQ*2HA 

) 

GOTO 

100 

IF 

(IANS*EQ*2HB 

) 

GOTO 

200 

IF 

(IANS<EQt2HC 

) 

GOTO 

250 

IF 

(IANS*EQ*2HD 

) 

GOTO 

300 

IF 

(IANS<EQ*2HE 

) 

GOTO 

350 

IF 

(IANS.EQ*2HF 

) 

GOTO 

400 

IF 

(IANStEQ<2HG 

) 

GOTO 

450 

IF 

(IANS*EQ*2HH 

) 

GOTO 

500 

IF 

(IANS»EQ<-2HI 

) 

GOTO 

550 

IF 

(IANS*EQ*2HN0) 

RETURN 

WRITE  (LU7M200) 

GOTO  51 

C CHECK  EOR  ADH  RUN  <IARRY<2)  = 3) 

100  NN  = 1 

WRITE  (LUTjIOOO)  (TPSL  <l»l)yl  = 1,13) 

IF  (lARRY  (2)*E0*3)  GOTO  200 
C DISPLAY  HEADING  A ->  THICKNESS 

J = 1 
L = J - 1 
WRITE  (LUT,1020) 

WRITE  <LUr,1050)  (TPSL  (2, I), I = 1,13) 

DO  105  K = 3,6 

WRITE  (LUT,1100)  (TPSL  (K,I),I  = 1 , 13 ) , ( TOPSOI  (J,I),I  = 1,6) 
105  J = JTl 

GOTO  (140,135,110)  MODE 

C EDIT  EXPECTATIONS 

C USER  INPUT  ->  SUDHEADING  NUMBER 

110  II  = 0 

WRITE  (LUT,3020) 

111  READ  (LUr,)«0  II 
GOTO  145 

C USER  INPUT  ->  LAND  USE  OPTION  REFERENCE  NUMBER 

115  WRITE  (LUT,3030) 

116  READ  (LU\yt)  LUORN 

IF  (LU0RN*GE*1*AND.LU0RN<LE.6)  GOTO  120 
WRITE  (LUT,1200) 

GOTO  116 

120  IF  (NN^EQ.l)  GOTO  130 
II  ==  II  + L 

C USER  INPUT  “>  EXPECTATION  VALUE 

130  WRITE  (LUT,3040) 

131  READ  (LUT,YO  TOPSOI  (II, LUORN) 

1 F ( TOPSOI (11, LUORN ) ♦ 6E ♦ 0 * AND  < TOPSOI (II, LUORN ) . LE . 4 ) 

> GOTO  600 
WRITE  (LUT,3050) 

GOTO  131 
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0167 

0168 

0169 

0170 

0171 

0172 

0173 

0174 

0175 

0176 

0177 

0178 

0179 

0180 

0181 

0182 

0183 

0184 

0185 

0186 

0187 

0188 

0189 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

0197 

0198 

0199 

0200 

0201 

0202 

0203 

0204 

0205 

0206 

0207 

0208 

0209 

0210 

0211 

0212 

0213 

0214 

0215 

0216 

0217 

0218 

0219 

0220 

0221 

0222 


C 

C 


C 

C 


C 


C 


C 


C 


C 


135 

136 


137 

138 


140 

144 


145 

146 

150 

151 
160 


166 

170 


176 

180 


200 


205 


210 

211 

250 


EDIT  RESPONSES 


USER  INPUT  ->  HEADING  *A‘  CHANGE 
WRITE  <LUT>2045) 

READ  (LUTj)*:)  IANS 

IF  (IANS*EQ*0)  GOTO  600 

IF  <IANS*GE*1 « AND« IANS<LE*4)  GOTO  ( 137 > 1 76 » 151 y 166 ) IANS 
WRITE  <LUT,1200) 

GOTO  136 

lOLD  = RTOPSO  <NN) 

WRITE  <LUT>2040)  lOLD 
GOTO  144 

INPUT  CATEGORY  RESPONSES 
USER  INPUT  ->  RTOPSO  CNN) 

WRITE  (LUT?2000) 


READ  <LUT)-)iO  RTOPSO  (NN) 

IF  (RTOPSO  (NN)<EQ<0)  GOTO  <900>146)  MODE 
II  = RTOPSO  (NN) 

IF(II*GE*1»AND>II.LEMT0P  (NN))  GOTO  (700, 600?  1 15)  MODE 
WRITE  (LUT,1200) 

GOTO  (144,144,111)  MODE 

IF  (M0DE»EQ*1)  GOTO  160 

USER  INPUT  “>  COST  TO  REMOME  TOPSOIL 
WRITE  (LUT,2050)  CSTRM 
WRITE  (CUT, 1025) 

READ  (LUT,:<0  CSTRM 
GOTO  (170,600)  MODE 

USER  INPUT  ->  COST  TO  REPLACE  TOPSOIL 
WRITE  (LUT,2060)  CSTRP 
WRITE  (LUT,1026) 

READ  (LUT,)4i)  CSTRP 
GOTO  (180,600)  MODE 


USER  INPUT  ->  ACTUAL  THICKNESS  OF  TOPSOIL 


WRITE  (LLIT,2070)  THKTS 
WRITE  (LUT,1027) 

READ  (LUT,5^:)  THKTS 
GOTO  (200,600)  MODE 

DISPLAY  HEADING  B ~>  PERCENT  ORGANIC  MATTER 


NN  = 2 


IF  (*NOT*LER) 
CALL  ERASE 
CALL  HOME 
WRITE  (LUT,1000) 
WRITE  (LUr,1020) 
J = I TOP  (1)  -f 
L ==  J ” 1 
WRITE  (LUT,1050) 
DO  210  K = 9,11 
WRITE  (LUT,1100) 
J = Jfl 

GOTO  (140,137,11 


GOTO  205 
(TPSL  (1,1),  I = 

1 

( (TPSL  (K,I),1 
(TPSL  (K,I),I  = 
) MODE 


, 13) 

1,13) ,K  = 7,8) 
1,13),  (TOPSOI 


( J,I) 


, I = 


DISPLAY  HEADING  C ->  TEXTURE 

NN  = 3 

IF  ( *NOT*LER)  GOTO  255 
CALL  ERASE 
CALL  HOME 

WRITE  (LUT,1000)  (TPSL  (1,I),1  = 1,13) 


1,6) 
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0223 

0224 

0225 

0226 

0227 

0228 

0229 

0230 

0231 

0232 

0233 

0234 

0235 

0236 

0237 

0238 

0239 

0240 

0241 

0242 

0243 

0244 

0245 

0246 

0247 

0248 

0249 

0250 

0251 

0252 

0253 

0254 

0255 

0256 

0257 

0258 

0259 

0260 
0261 
0262 

0263 

0264 

0265 

0266 

0267 

0268 

0269 

0270 

0271 

0272 

0273 

0274 

0275 

0276 

0277 

0278 


260 

C 

300 


303 


305 

C 

350 


355 


360 

C 

400 


405 


410 

C 

450 


455 


J = ITOP  (1)  + IIGP  (2)  + 1 

L = J - 1 

WRITE  <LUT»1020) 

WRITE  (LUT»1050)  (TPBL  <12»1)j1  = 1^13) 

DO  260  K = 13yl8 

WRITE  (LUfyllOO)  (TPSL  <K»I)»I  = 1 > 13) > ( TOPSOI  <J»I)»I 
J = J+1 
GOTO  211 

DISPLAY  HEADING  D ->  STRUCTURE 


NN  = 4 

IF  <*NOT*LER)  GOTO  303 
CALL  ERASE 
CALL  HOME 

WRITE  <LUT,1000)  (TPSL  (IjI)jI  = 1»13)  ' 

J = ITOP  (1)  + ITOP  (2)  + ITOP  (3)  + 1 

L = J - 1 

WRITE  (LUT»1020) 

WRITE  (LUTyl050)  < (TPSL  (KM)»I  = 1»13)5K  = 19»20) 

DO  305  K = 21y23 

WRITE  (LUfjllOO)  (TPSL  (Kfl)rl  = 1 , 13) > (TOPSOI  (Jyl)rl 
J = Jil 
GOTO  211 

DISPLAY  HEADING  E ->  BULK  DENSITY 


NN  = 5 

IF  (*NOT*LER)  GOTO  355 
CALL  ERASE 
CALL  HOME 

WRITE  (LUTjIOOO)  (TPSL  (1jI)»1  = 1j13) 

WRITE  (LUI»1020) 

J = ITOP  (1)  + ITOP  (2)  + ITOP  (3)  + ITOP  (4)  + 1 
L = J - 1 

WRITE  (LUT»1050)  ( (TPSL  (K,I)j1  = l»13)yK  = 24y25) 

DO  360  K = 26j27 

WRITE  (LUTyllOO)  (TPSL  (Kyl)yl  = 1 y 13 ) y ( TOPSOI  (Jyl)yl 
J = Jil 
GOTO  211 


DISPLAY  HEADING  F ~>  SALINITY 


NN  = 6 

IF  (*NOT*LER)  GOTO  405 
CALL  ERASE 
CALL  HOME 

WRITE  (LUTyiOOO)  (TPSL  (lyl)yl  = lyl3) 

WRlfE  (LUTyl020) 

J = ITOP  (1)  T ITOP  (2)  ■}•  ITOP  (3)  -f  ITOP  (4)  + ITOP  (5) 
L = J --  1 

WRITE  (LUTylOSO)  (TPSL  (28yl)yl  = lyl3) 

DO  410  K = 29y33 

WRITE  (LUTyllOO)  (TPSL  (Kyl)yl  = 1 y 13 ) y ( TOPSOI  (Jyl)yl 
J = J+1 
GOTO  211 

DISPLAY  HEADING  G -■>  SODIUM  ADSORPTION  RATIO 

NN  = 7 


IF  (.NOT.LER)  GOTO  455 
CALL  ERASE 
CALL  HOME 

WRITE  (LUTyiOOO)  (TPSL  (lyl)yl  = lyl3) 


= 1?6) 


= ly6) 


= ly6) 


+ 1 


= 1 y 6 ) 


289 


0279 

0280 
0281 
0282 

0283 

0284 

0285 

0286 

0287 

0288 

0289 

0290 

0291 

0292 

0293 

0294 

0295 
0296' 

0297 

0298 

0299 

0300 

0301 

0302 

0303 

0304 

0305 

0306 

0307 

0308 

0309 

0310 

0311 

0312 

0313 

0314 

0315 

0316 

0317 

0318 

0319 

0320 

0321 

0322 

0323 

0324 

0325 

0326 

0327 

0328 

0329 

0330 

0331 

0332 

0333 

0334 


WRITE  <LUr>1020) 

J = ITOP  (1)  + ITOP  (2)  + ITOP  (3)  + ITOP  <4)  + ITOP  (5)  + 
+ ITOP  (6)  + 1 
L = J - 1 

WRITE  (LUTjIOSO)  < (TPSL  (K^D^I  = 1,13)»K  = 34»35) 

DO  460  K = 36^39 

WRITE.  (LOT, 1100)  (TPSL  <KyI),I  = 1 r 13 ) » ( TOPSOI  (J»I)rI  = 
460  J = J+1 
GOTO  211 


C DISPLAY  HEADING  H ->  NITROGEN 

500  NN  = 8 

IF  <*NOT.LER)  GOTO  505 
CALL  ERASE 
CALL  HOME 

WRITE  (LOT, 1000)  (TPSL  (ItDtI  = 1>13) 

505  WRITE  (LOT >1020) 

J = ITOP  (1)  + ITOP  (2)  + ITOP  (3)  + ITOP  (4)  + ITOP  (5)  + 
+ ITOP  (6)  + ITOP  (7)  + 1 
L = J - 1 

WRITE  (LUT>1050)  ( (TPSL  (K>I)>I  = 1>13)»K  = 40>41) 

DO  510  K ==  42>44 

WRITE  (LUIjIIOO)  (TPSL  (K>I)>I  = 1 > 13) > (TOPSOI  (J>I)>I  = 
510  J = JTl 
GOTO  211 

C DISPLAY  HEADING  I ~>  PHOSPHORUS 

550  NN  = 9 

IF  (♦NOT*LER)  GOTO  555 
CALL  ERASE 
CALL  HOME 

WRITE  (LUTjIOOO)  (TPSL  (1>I)>I  = 1>13) 

555  WRITE  (LUT>1020) 

J = ITOP  (1)  + ITOP  (2)  + ITOP  (3)  + ITOP  (4)  i ITOP  (5)  T 
+ ITOP  (6)  -I  ITOP  (7)  -f  ITOP  (8)  + 1 
L = J - 1 

WRITE  (LUT>1050)  ( (TPSL  (K>I)>I  = 1>13)?K  = 45>46) 

DO  560  K = 47 >49 

WRITE  (LUf>1100)  (TPSL  (K>I)>I  = 1 > 13 ) > ( TOPSOl  (J>I)>I  = 
560  J = J+1 
GOTO  211 

C USER  INPUT  “>  MORE  EDITS  ? 

600  WRITE  (LUT>3060) 

READ  (LUT>2030)  IANS 

IF  (1ANS*NE*2HYE)  RETURN 
GOTO  1 

C INPUT  MODE  ”>  DIRECT  TO  PROPER  HEADING 

700  IF  (NN*EQ*NTOP)  RETURN 

GOTO  (160>250>300>350>400>450>500>550)  NN 
C USER  WANTS  OUT  ->  SET  EXIT  TO  ZERO  AND  RETURN 

900  EXIT  = 0 
RETURN 

C FORMAT  STATEMENTS 

1025  FORMAT  ( -COST  TO  REMOOE  TOPSOIL  ( CENTS/CU ♦ YD ) ->  _') 

C 

1026  FORMAT  ( -COST  TO  RESPREAD  TOPSOIL  (CENTS/CU * YD ) ->  _') 

C 

1027  FORMAT  ( -ACTUAL  THICKNESS  OF  TOPSOIL  (IN*)  ->  _*) 


1 > 6 ) 


1 > 6 ) 


1>6) 
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0335 

0336 

0337 

0338 

0339 

0340 

0341 

0342 

0343 

0344 

0345 

0346 

0347 

0348 

0349 

0350 

0351 

0352 

0353 

0354 

0355 

0356 

0357 

0358 

0359 

0360 

0361 

0362 

0363 

0364 

0365 

0366 

0367 

0368 

0369 

0370 

0371 

0372 

0373 

0374 

0375 

0376 

0377 

0378 

0379 

0380 

0381 

0382 

0383 

0384 

0385 

0386 

0387 

0388 

0389 

0390 


2045  FORMAT (5X* WHERE  IS  YOUR  CHANGE 
X5X'0)  NO  CHANGE'/^ 

&5X'l)  THICKNESS  (CATEGORY) V , 
g5X"2)  ACTUAL  THICKNESS  (INCHES) */y 
S5Xy"3)  COST  TO  REMOOE  SOIL  FOR  STORAGE"/? 

X5X"4)  COST  TO  RESPREAD  TOPSOIL"/? 

S5X"ENTER  YOUR  CHOICE  HERE  ->  >.") 

2050  FORMAT  ( 5X"C0ST  TO  REMOVE  TOPSOIL  IS  CURRENTLY " F5 . 1 ? IX 
8"CENTS/CU<  YD«  "/) 

2060  FORMAT  ( 5X"C0ST  TO  RESPREAD  TOPSOIL  IS  CURRENTLY " F5 ♦ 1 ? IX 
S"CENTS/CU*YD« “/) 

2070  FORMAT  ( 5X" ACTUAL  THICKNESS  OF  TOPSOIL  IS  CURRENTLY " F7 ♦ 2 ? IX 

^"INCHES* "/) 

1000  FORMAT  ( 13A2?  44  (")Jc")?  /?  26X?  "5tc"? 

SlOX?  "STANDARD  EXPECTATIONS"?  IIX?  "JJc"?  /? 

&26X?  44  ("3«(")?  /?  26X?  " )JcCR0P5f: " ? 2X? 

^"NATIVE"?  2X?  ")jcWILD^JJ"  ? 2X?  "WATER"?  3X? 

&"3«cHIGH3«cOTHER)Jc"  ? /?  26X? 

&")JcLAND3<iVEGETAI  10N)JcLlFE)}cRECREATI0N:4:USE  5fc"?  5X?  "){c") 

C 

1020  FORMAT  (70  /?  26X?  " 4X " :^c  ‘ lOX " " 4X " " lOX " " 4X " " 5X " " ) 

C 

1050  FORMAT  (13A2?  ":<?"?  4X?  "5J:"?  lOX?  ")(("?  4X?  ‘f  9 
iilOX?  -ff  4X?  ")^c•?  5X?  ")fc") 

C 

1100  FORMAT  (13A2? 

S»)fc  ‘ll*  t "II"  t "II"  t "II"  t "II"  t "11" 


1200  FORMAT  (/"YOU  HAVE  TYPED  IN  AN  ILLEGAL  ANSWER*"? 
&/?  "GIVE  HER  ANOTHER  SHOT  ~>  .") 

C 

2000  FORMAT  ("ENTER  THE  APPROPRIATE  "?  4X? 

&44  (")f(")?  /?  "NUMBER?  OR  ZERO  TO  QUIT  ~>  -") 

C 

1010  FORMAT  ( 17X"INPUT  RESPONSES/TOPSOIL"//) 

C 

2010  FORMAT  ( 17X"EDIT  RESPONSES/TOPSOIL"//) 

C 


3010  FORMAT  ( 17X"EDIT  EXPECTATIONS/TOPSOIL"//) 

C 

2020  FORMAT  (/?  5X"IN  WHICH  HEADING  IS  YOUR  DESIRED  EDIT?"/? 
&5X"  (ENTER  A?B?C?D?E?F?6?H?  OR  I OR  NONE)  ->  _") 

C 

2030  FORMAT  (A2) 

C 


2040  FORMAT  (/?  5X"Y0UR  CURRENT  RESPONSE  IS  “>'I1?  //? 

&5X" ENTER  YOUR  NEW  RESPONSE  HERE  ->  _") 

C 

3020  FORMAT  (/?  5X"1N  WHICH  SUB-HEADING  IS  THE  EXPECTATION  VALUE"/? 
Ji5X"Y0U  WISH  TO  CHANGE  ? (ENTER  THE  APPROPRIATE  NUMBER)  ->  _") 
C 


3030  F0RMAT(/5X"SELECT  THE  LAND  USE  OPTION  YOU  WISH  TO  CHANGE"/ 

> IX"  -1-  / -2-  / -3-  / -4-  / -5-  / -6-  /•/ 

> 1X"CR0PLAND/NAT* VEG*/WILDLIFE/WAT*REC«/HI6H  USE/  OTHER/" 
>/5X"ENTER  YOUR  SELECTION  HERE  ->  ^") 
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0391 

C 

0392 

3040 

FORMAT  </>  5X"FNTER  YOUR  NEW  EXPECTATION 

VALUE  HERE  ~>  _*) 

0393 

C 

0394 

3050 

FORMAT  </>  5X"ERR0R — > YOUR  EXPECTATION 

VALUE  MUST  BEWf 

0395 

>5X"0»l>2»3y  OR  4 TO  AVOID  INTRODUCING  A 

BIAS  ->  _•) 

0396 

C 

0397 

3060 

FORMAT  </f  5X"ANY  MORE  EDITS  70  TOPSOIL 

?•/» 

0398 

&5X*  (YES  OR  NO)  ~> 

0399 

C 

0400 

C 

0401 

END 

0402 

0403 

END 

0404 

♦ 
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STSBLA  T=00004  IS  ON  CR00015  USING  00033  BLKS  K-0192 


0001  FTN4 

0002  SUBROUTINE  TSBLA  < IPTR ? ICHB y PARAMl y PARAM2 ) 

0003  C TRUCK  AND  SHOVEL  : DENCH  LENGTH  ADJUSTMENTS 

0004  C 

0005  C LEVEL  4 

0006  C 

0007  C THIS  ROUTINE  ADJUSTS  THE  BENCH  LENGTHS  TO  ACCOMODATE  A CHANGE  IN 

0008  C THE  INITIAL  BENCH  WIDTHS?  THE  INITIAL  HIGHWALL  HEIGHTS?  OR  THE 

0009  C INITIAL  HIGHWALL  SLOPES?  SO  THAT  THE  ANGLES  DEFINED  BY  THE  INITIAL 

0010  C INPUT  DATA  REMAINS  THE  SAME  FOR  SEMI-CIRCULAR  TRUCK  AND  SHOVEL 

0011  C PRODUCED  SPOILS* 

0012  C 

0013  C TSBLA  IS  ACCESSED  BY  TSIHB ? TSSCI ? TSXBA ? AND  TSIFN 

0014  C 

0015  C THE  CALLING  SEQUENCE  IS  : 

0016  C 

0017  C CALL  TSBLA  ( IPTR? ICHB?PARAM1 ?PARAM2) 

0018  C 

0019  C WHERE  J 

0020  C 

0021  C 

0022  C 

0023  C 

0024  C 

0025  C 

0026  C 

0027  C 

0028  C 

0029  C 

0030  C 

0031  C 

0032  C 

0033  C 

0034  C 

0035  C 

0036  C 

0037  C 

0038  C 

0039  C 

0040  C 

0041  C 


0042 

C 

SUBROUTINE 

S SCHEDULED  ARE  : 

0043 

C 

0044 

C 

BELL 

(TCS) 

0045 

C 

TINPT 

(TCS) 

0046 

C 

0047 

C 

THE  LOCAL 

VARIABLES  ARE  : 

0048 

C 

0049 

C 

ADBCD 

->  ANGLES  DEFINED  BY  CURRENT  DATA  (RADIANS) 

0050 

C 

BLMAX 

“>  MAXIMUM  POSSIBLE  BENCH  LENGTH  (FEET) 

0051 

C 

BLMIN 

->  MINIMUM  POSSIBLE  BENCH  LENGTH  (FEET) 

0052 

C 

CMA 

->  CURRENT  MINIMUM  ANGLE  (RADIANS) 

0053 

C 

ICHAR 

->  TINPT  RETURN 

0054 

C 

ICHBl 

->  NUMBER  OF  BENCHES  THAT  NEED  ADJUSTING 

IPTR  ->  POINTER  : 

0 - TSBLA  RETURNS  THIS  VALUE  WHEN  AT  LEAST  ONE 

BENCH  LENGTH  EXCEEDED  THE  MAXIMUM  POSSIBLE 

1 - ADJUST  BENCH  LENGTHS  ON  THE  BASIS  OF  A CHANGE 

IN  BENCH  “ICHB*  WIDTH  ONLY 

2 - ADJUST  BENCH  LENGTHS  ON  THE  BASIS  OF  A CHANGE 

IN  BENCH  'ICHB*  AND  “ICHB-1'  WIDTHS 

3 - TEST  FOR  MAXIMUM  & MINIMUM  BENCH  LENGTHS 

4 - ADJUST  BENCH  LENGTHS  ON  THE  BASIS  OF  A CHANGE 

IN  THE  INITIAL  HIGHWALL  HEIGHT 

5 - ADJUST  BENCH  LENGTHS  ON  THE  BASIS  OF  A CHANGE 

IN  THE  INITIAL  HIGHWALL  SLOPE 
ICHB  ->  CURRENT  HIGHWALL/BENCH  NUMBER 
PARAMl  ->  DEPENDING  ON  THE  VALUE  OF  IPTR?  THIS  IS  : 

IPTR  = 1 t THE  NEW  BENCH  WIDTH  FOR  BENCH  "ICHB' 

IPTR  = 4 : THE  NEW  HIGHWALL  HEIGHT  FOR  BENCH  'ICHB* 

IPTR  = 5 i THE  NEW  HIGHWALL  SLOPE  FOR  BENCH  -ICHB' 

PARAM2  ->  THE  NEW  BENCH  WIDTH  FOR  BENCH  "ICHB-l' 

(USED  ONLY  FOR  IPTR  = 2) 
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0055 

0056 

0057 

0058 

0059 

0060 

0061 

0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 

0081 

0082 

0083 

0084 

0085 

0086 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 

0101 

0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


C RBOE  ->  RADII  OF  BENCHES  (OUTSIDE  EDGE  “ FEET) 

C XWIH  ->  CROSS-SECTIONAL  WIDTH  OF  INITIAL  HIGHWALLS  (FEET) 

C 

C THIS  ROUIINE  WAS  WRITTEN  BY  GREEN 
C 

C CLAIM  RELEASE  1*0  - APRIL  It  1980 

C 

C 

C 

C TEKTRONIX  COMMON 

C 

COMMON  ITEK  (45) 

C I 

C LOGICAL  UNITS  AND  COMMON  LOCATION 

C 

COMMON  IARRY(5) jIARY2(5) »LER»LUF>LUL 
C 

C POINTERS 

C 

COMMON  EXIT  > IANM(3) , ICLI (2) > IGEN(3) ? IGRW(5) 

COMMON  lOPTN  ,I00R(7)»IHB  » ISOC ( 6 ) ? ISUB ( 8 ) 

COMMON  ISUR(6) » IT0P(9) ? lOEG ( 2 ) > LEXIT  ?LUO 
COMMON  MODE  yNANM  jNCLI  jNGEN  ,NGRW 

COMMON  NOOR  »NSECTS  yNSOC  jNSUB  fNSUR 

COMMON  NT  OP  rNU  j NOEG 

C 

C GRADING  PARAMETERS 

C 

COMMON  AREA ( 5 ) » BENLEN (5^10)?  BENW I ( 5 y 1 0 ) > C060  y GCPA ( 5 ) 

COMMON  SPCC(5) yHWHT(5y 10) y HWSLI ( 5 y 1 0 ) y NHBP ( 5 ) yPCEQ19(4) 
COMMON  BENWF(5y 10) yREHCPY(5) y REH00L(5) yHWSLF(5y 10) yUSR 
C 

C CATEGORY  TEXT 

C 

COMMON  ANIM(23y 13) y CLMA( 13y 13) y GDES( 15y 13) y GWHY(22y 13) 
COMMON  00BD(llyl3)ySBSL(13)y  SCEC( 33 y 13 ) y SWHY ( 44 y 13 ) 

COMMON  TPSL(49y 13) y VGTA(15y 13) 

C 

C EXPECTATION  VALUES 

C 

COMMON  ANIMAL (13y6)yCLIMAT(8y6)y  GENDES ( 8 y 6 ) y GRWH YD ( 1 9 y 6 ) 
COMMON  0VRBDN(2By6) y BOCECN ( 29 y 6 ) y SUBSOI ( 30 y 6 ) y SURHYD ( 23 y 6 ) 
COMMON  T0PS0I(33y6) y VE6ETA(10y6) 

C 

C CATEGORY  RESPONSES 

C 

COMMON  RANIMA(3) yRCLIMA(2) yRGENDE(3) yRGRWHY(5) 

COMMON  R0VRBD(7y 10) y RSOCEC ( 6 ) y RSUBSO ( 8 ) y RSURHY ( 6 ) 

COMMON  RT0PS0(9) yRVEGET(2) 

C 

C FEASIyTECONyOPUSE  SUBSYSTEM  PARAMETERS 

C 

COMMON  CAAHMyCABAHyCABFN(3) yCABFP(3) yCABHM 
COMMON  CABS ( 2 ) y CAC  y CACP  y CADF  y CADH 
COMMON  CADS  y CAEAF  y CAHSAF  y CAHSTS  y CAIP 
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0111 

0112 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120 

0121 

0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

C!  33 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 

0161 

0162 

0163 

0364 

0165 

0166 


COMMON  CAR3KC  r CASF  > CASNC  y CSTES  > CST  RM 

COMMON  CSTRP  > KA06 ( 5 ) » PFSTSP  » PFAC » RCLTEC ( 29 > 34 ) 

COMMON  TCAR(5)  > THICKdO)  >THKTSjTTL<40) 


C 


C 


C 


C 


INTEGER  EXIT»CLMAy6DESjGUHYy00BLi»B8SL 
INTEGER  SCECf SWHYdPSLy VGTAj ANIM 
INT  EGER  CL I MAT  » GENDES  y GRWHYD  y 00R8DN 
INT  EGER  SOCECN  y SUBSO I y SURHYD  y T OPSO I 
INTEGER  OEGETAyANIMAL 

INTEGER  RCL I MA  y RGENUE  y RGRWHY  y ROORfcD  y RSOCEC 
INTEGER  RSUBSOyRSURHYyRTOPSOyROEGET  yRANIMA 
INTEGER  RCLTECyTTL 


INTEGER  COMMON  <1) 

EQUIVALENCE  (COMMON  (l)y  ITEK  < 


EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 


(lARRY 

(1ARY2 

(1ARY2 

(IARY2 

(1ARY2 


(1)  y 

(1)  y 

(2)  y 

(3)  y 

(4)  y 


LUT) 
ISTRK) 
ISECT) 
I CODE) 
LEN) 


1)  ) 


LOGICAL  LER 


DIMENSION  XWIH  (10) y RBOE  (10) y ADBCD  (10) 

C 

C FIRST y DETERMINE  THE  ANGLES  DEFINED  BY  THE  CURRENT  DATA 

C 

DO  10  I = ly  NHBP  (LUO) 

10  XWIH  (I)  = HUHT  (LUOy  I)  / TAN  (HWSLI  (LUOy  I)  t *01745) 
RBOE  (1)  = BENUI  (LUOy  1) 

IF  (NHBP  (LUO)  *EQ*  1)  GOTO  40 
DO  20  I = 2y  NHBP  (LUO) 

20  RBOE  (1)  = RBOE  (1)  + XWIH  (I)  + BENWI  (LUOy  I) 

DO  30  I = 2y  NHBP  (LUO) 

30  RBOE  (I)  = RBOE  (1  - 1)  - BENWI  (LUOyI-1)  - XWIH  (I) 

40  IF  (IPTR  *EQ<  3)  GOTO  300 
DO  50  I = ly  NHBP  (LUO) 

50  ADBCD  (I)  = BENLEN  (LUOy  I)  / RBOE  (I) 

GOTO  (lOOy  lOOy  900y  400y  500)  IPTR 
C 

C ADJUSTMENTS  ARE  BASED  ON  BENCH  WIDTH  CHANGES 

C 

100  I = ICHB 

RBOE  (I)  = RBOE  (I)  + PARAMl  - BENWI  (LUOy  I) 

IF  (IPTR  *EQ.  2)  105y  110 

105  RBOE  (I  - 1)  = RBOE  (I)  + XWIH  (I)  T PARAM2 
1 = 1-1 
110  I = I - 1 

IF  (I  *EQ*  0)  GOTO  600 

RBOE  (1)  = RBOE  (I  + 1)  + XWIHd  + l)  + BENWI  (LUOy  1) 

GOTO  110 
C 

C TEST  FOR  MAXIMUM  & MINIMUM  BENCH  LENGTHS 

C 


300  DO  310  I = ly  NHBP  (LUO) 

BLMAX  = RBOE  (I)  t 6*28319 
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0167 

0168 

0169 

0170 

0171 

0172 

0173 

0174 

0175 

0176 

0177 

0178 

0179 

0180 

0181 

0182 

0183 

0184 

0185 

0186 

0187 

0188 

0189 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

0197 

0198 

0199 

0200 

0201 

0202 

0203 

0204 

0205 

0206 

0207 

0208 

0209 

0210 

0211 

0212 

0213 

0214 

0215 

0216 

0217 

0218 

0219 

0220 

0221 

0222 


305 

310 

311 
315 


320 


C 

C 

C 

400 


C 

C 

C 

500 


C 

C 

C 

600 


610 


C 

C 

C 

900 


C 

C 

C 


1000 

C 

1010 


C 


IF  (BENLEN  (LUOr  I)  .LE*  BLHAX)  310>  305 
WRITE  (LUT»  1000)  ly  BENLEN  (LUO>  I) 

BENLEN  (LUOy  1)  = BLMAX 

WRITE  (LUTy  1010)  BENLEN  (LUOy  I) 

IPTR  = 0 
CONTINUE 

IF  (NHBP  (LUO)  ♦EQ*  1)  GOTO  900 
I = NHBP  (LUO)  - 1 

C«A  = BENLEN  (LUOy  I+l)  / RBOE  (I  + 1) 

BLMIN  = RBOE  (I)  t CHA 

IF  (BENLEN  (LUOy  I)  .LT*  BLMIN  ) 315y  320 
WRITE  (LUTy  1000)  ly  BENLEN  (LUOy I) 

BENLEN  (LUOy I)  = BLMIN 

WRITE  (LUTy  1010)  BENLEN  (LUOy I) 

IPTR  = 0 
1 = 1-1 

IF  (I  0)  900y  311 

ADJUSTMENTS  BASED  ON  CHANGE  IN  HI6HWALL  HEIGHT 
I = ICHB 

XWIH  (I)  = PARAMl  / TAN  (HWSLl  (LUOy  I)  * *01745) 

GOTO  110 

ADJUSTMENTS  BASED  ON  CHANGE  IN  INITIAL  HIGHWALL  SLOPE 

j 

I = ICHB 

XWIH  (1)  = HWHT  (LUOy  I)  / TAN  (PARAMl  t *01745) 

GOTO  110 

MAKE  THE  ADJUSTMENTS 


ICHBl  = ICHB 

IF  (IPTR  *EQ*  4 *0R*  IPTR  *ECn  5)  ICHBl  = ICHB  - 1 
IF  (LER)  CALL  ERASE 
IF  (LER)  CALL  HOME 
DO  610  I = ly  ICHBl 

WRITE  (LUTy  1000)  ly  BENLEN  (LUOy  I) 

BENLEN  (LUOy  1)  = RBOE  (I)  t ADBCD  (I) 

WRITE  (LUTy  1010)  ^ BENLEN  (LUOy  I) 


DONE 

IF  (*NOT*  LER)  RETURN 
WRITE  (LUTy  1020) 

CALL  BELL 
CALL  TINPT  (I CHAR) 
CALL  ERASE 
RETURN 

FORMAT  STATEMENTS 


FORMAT  (/y5X" BENCH  LENGTH  "12"  'S  VALUE  OF 'F 13. 3*  FEET') 
FORMAT  (SX'HAS  BEEN  ADJUSTED  T0'F13*3'  FEET*) 
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0223  1020  rORHAT  </t5X*H1T  THE  RETURN  KEY  TO  CONT  INUE  'f  ♦ ^ ) 


t 0224 
0225 
1 0226 


END 

END$  , * - 
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FTN4 

SUBROUTINE  TSDBR  (HEIGHT y SLINI , SLFIN ? BR ) 

C TRUCK  AND  SHOOEL  : DETERMINE  BENCH  REMOVED  

C 

C LEVEL  5 
C 

C THIS  ROUTINE  RETURNS  THE  BENCH  REMOVED  BY  GRADING  FROM 

C THE  INITIAL  SLOPE  TO  THE  FINAL  SLOPE* 

C 

C CALLING  sequence: 

C 

C CALL  TSDBR  (HEIGHTjSLINI tSLFINjBR)  | 

C 

C WHERE 
C 

C HEIGHT  ->  HIGHWALL  HEIGHT 

C SLINI  ->  INITIAL  HIGHWALL  SLOPE 

C SLFIN  ~>  FINAL  HIGHWALL  SLOPE 

C BR  ->  BENCH  REMOVED 

C 

c LOCAL  variables: 

C 

C ADJl  ~>  X-SECTIONAL  WIDTH  OF  HIGHWALL  BASED  ON  INITIAL  SLOPE 

C ADJ2  ->  X-SECTIONAL  WIDTH  OF  HIGHWALL  BASED  ON  FINAL  SLOPE 

C RSLFIN  ->  FINAL  SLOPE  IN  RADIANS 

C RSLINI  ~>  INITIAL  SLOPE  IN  RADIANS 

C 

C THIS  ROUTINE  WAS  WRITTEN  BY  EASTMAN 
C 

C CLAIM  RELEASE  1*0  - APRIL  1j  1980 

C 

C 

C 

C CONVERT  SLINI  AND  SLFIN  TO  RADIANS 

C 

RSLINI  = SLINI  ^ *01745 
RSLFIN  = SLFIN  t <,01745 
C 

C DETERMINE  ADJl  AND  ADJ2 

C 

ADJl  = (HEIGHT  / 2*)  / TAN(RSLINI) 

ADJ2  = (HEIGHT  / 2*)  / TAN(RSLFIN) 

C 

C NOW  CALCULATE  BR 

C 

BR  = ADJ2  - ADJl 
IF(SLINI *EQ*SLFIN)  BR  = 0* 

RETURN 

END. 

END$ 
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FTN4 

SUBROUTINE  TS6E 

C TRUCK  AND  SHOVEL  GRADING  EXECUTIVE 

C 

C LEVEL  2 
C 

C TSGE  IS  THE  TRUCK  AND  SHOVEL  GRADING  EXECUTIVE.  INPUTS  AND 

C EDITS  TO  BOTH  THE  INITIAL  HIGHWALL/BENCH  DESCRIPTION  AND  THE 

C GRADED  TOPOGRAPHY  ARE  REPEATEDLY  OFF ERRED  TO  THE  USER.  AT 

C USER  REQUEST?  CROSS-SECTIONAL  VIEWS  OF  THE  CURRENT  HIGHWALL/ 

C BENCH  PAIR  WILL  BE  DISPLAYED  DURING  INPUT  OF  FINAL  SLOPES. 

C SUMMARY  DATA  COMPRISING  VOLUMES  AND  COSTS  FOR  GRADING  EACH 

C HIGHWALL  / BENCH  PAIR  AND  GRAND  TOTAL  COSTS  ARE  AVAILABLE 

C ON  THE  TERMINAL?  LINE  PRINTER?  OR  CALCOMP  PLOTTER? 

C DEPENDING  ON  USER  PREFERENCE. 

C 

C TSGE  IS  ACCESSED  BY  GDE  AND  CLAIM?  AND  SWAPPED  IN  BY  PROGRAM  TS6EX 
C 

C THE  CALLING  SEQUENCE  IS  I 
C 

C CALL  TSGE 

C 

C TSGE  SCHEDULES  THE  SUBROUTINES  t 
C 

C TSIFG  TO  INPUT  FINAL  SLOPES  IN  THE  'GRAPHIC*  MODE 
C TSIFN  TO  INPUT  FINAL  SLOPES  IN  THE  "NON-GRAPHIC  MODE 
C TSIHB  TO  INPUT  THE  INITIAL  HIGHWALL  / BENCH  DATA 
C TSRIE  TO  INPUT  REHANDLE  DATA 

C TSSCF  TO  SCHEDULE  SELECTIVE  CHANGES  TO  FINAL  SLOPES 
C TSSCI  TO  SCHEDULE  SELECTIVE  CHANGES  10  INITIAL  DATA 
C TSST  TO  PRINT  A SUMMARY  TABLE 

C TSXST  TO  PRESENT  A SUMMARY  TABLE  WITH  CROSS-SECTION  OF  SPOILS 
C 

C TSGE  USES  THE  TCS  ROUTINES  ERASE  AND  HOME 
C AND  DECLARES  LABEL  COMMON  ALTRN 
C 

C THE  LOCAL  VARIABLES  ARE  t 
C 

C IANS  - ANSWER  CELL 

C IPTR  - POINTER  TO  EDIT  OPTION 

C 

C THIS  ROUTINE  WAS  WRITTEN  BY  GREEN 
C (PATTERNED  AFTER  “GRADE*  BY  EASTMAN) 

C 

C CLAIM  RELEASE  1.0  - APRIL  1?  1980 

C 

C TEKTRONIX  COMMON 

C 

COMMON  ITEK  (45) 

C 

C LOGICAL  UNITS  AND  COMMON  LOCATION 

C 

COMMON  1ARRY<5) ? I ARY2 ( 5 ) ? LER ? LUF ? LUL 
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0055  C 

0056  C 

0057  C 

0058 

0059 

0060 
0061 
0062 
0063 
006A  C 

0065  V, 

0066  C 

0067 

0068 

0069 

0070  C 

0071  C 

0072  C 

0073 

0074 

0075 

0076  C 

0077  C 

0078  C 

0079 

0080 
0081 

0082  C 

0083  C 

0084  C 

0085 

0086 

0087 

0088  C 

0089  C 

0090  C 

0091 

0092 

0093 

0094 

0095 

0096 

0097  C 

0098 

0099 

0100 
0101 
0102 

0103 

0104 

0105 

0106  C 

0107 

0108 

0109 

0110 


POINTERS 

COMMON  EXIT  > 1ANMC3) , ICLK2)  y IGEN(3)  » IGRW(5) 

COMMON  lOPTN  > lOOR < 7 ) » II IB  > IS0C<6) y IGUB(8) 

COMMON  ISUR(6) y IT0P(9) >I0EG<2) »LEXIT  ,LUO 
COMMON  MODE  jNANM  >NCLI  »N6EN  jNGRW 

COMMON  NOOR  ,NSECTS  jNSOC  >NSUB  >NSUR 

COMMON  NTOP  ?NU  >NOEG 

GRADING  PARAMETERS 

COMMON  AREA ( 5 ) y BENLEN ( 5 > 1 0 ) » BENWI ( 5 > 10 ) y COGO  > GCP A ( 5 ) 
COMMON  SPCC<5) yHWHT(5y 10) y HWSLI < 5 y 10 ) y NHBP < 5 ) yPCEQ19<4) 
COMMON  BENWP ( 5 y 1 0 ) y REHCP Y ( 5 ) y REHOOL ( 5 ) y HWSLF ( 5 y 1 0 ) y USR 

CATEGORY  TEXT 

COMMON  ANIM(23y 13) yCLMA(13y 13) y6DES(15y 13) yGWHY(22y 13) 
COMMON  00BD(llyl3)ySBSL<13)y  SCEC ( 33 y 13 ) y SWHY ( 44 y 1 3 ) 
COMMON  TPSL(49y 13) yOGTA(15yl3) 


EXPECTATION  VALUES 

COMMON  ANIMAL(13y6) yCLIMAT(8y6) yGENDES(8y6) yGRWHYD(19y 
COMMON  0VRBDN(28y6) y SOCECN ( 29 y 6 ) y SUBSOI ( 30 y 6 ) y SURHYD < 2 
COMMON  T0PS0I(33y6) y VEGETA(10y6) 

CATEGORY  RESPONSES 

COMMON  RANIMA(3) yRCLIMA(2) yRGENDE(3) yRGRWHY<5) 

COMMON  R0VRBD(7y 10) y RSOCEC ( 6 ) y RSUBSO < 8 ) y RSURHY < 6 ) 
COMMON  RT0PS0<9) yRVEGET<2) 


EEASIyTECONyOPUSE  SUBSYSTEM  PARAMETERS 

COMMON  CAAHM  y CABAH  y CABFN ( 3 ) y CABFP ( 3 ) y CABHM 

COMMON  CABS ( 2 ) y CAC  y CACP  y CADF  y CADH 

COMMON  CADS  y CAEAF  y CAHSAF  y CAHSTS  y CAIP 

COMMON  CAR3FC  y CASF  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y FAVG ( 5 ) y PFSTSP  y PF AC  y RCLTEC ( 29  y 34 ) 

COMMON  TCAR(5) yfHICK(lO) y THKTS y TTL < 40 ) 


INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 


EXIT  y CLMA  y GDES y GWHY  y OVBD y SDSL 
SCEC  y SWHY  y TPSL  y VGTA  y ANI M 
CL I MAT  y GENDES  y GRWHYD  y OVRBDN 
SOCECN y SUBSOI y SURHYD y TOPSOl 
VEGETAyANlMAL 

RCL IMA  y RGENDE  y RGRWHY  y RGVRBD  y RSOCEC 
RSUBSO  y RSURH Y y RTOPSO  y RVEGET  y RANIMA 
RCLTEC yTTL 


INTE6ER  COMMON  (1) 

EQUIVALENCE  (COMMON  <l)y  ITEK  (1)) 
EQUIVALENCE  (lARRY  <l)y  LUT) 
EQUIVALENCE  (1ARY2  <l)y  ISTRK) 
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0111 

0112 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120 

0121 

0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 

0161 

0162 

0163 

0164 

0165 

0166 


EQUIVALENCE  (IARY2  (2),  ISECT) 


EQUIVALENCE  (IARY2  (3)?  ICODE) 

EQUIVALENCE  (IARY2  <4)y  LEN) 

C 

LOGICAL  LER 
C 
C 

COMMON  / ALTRN  / ALTN 
INTEGER  ALTN  (6f4) 

C 

C TEST  MODE 

IF  (MODE  »EQ*  1 *0R*  MODE  *EQ*  4)  lOOr  500 
C INPUT  REHANDLE  DATA  FOR  MINE  RUN  AND  FINAL  CUT  OPTION 

100  IF  (RGENDE  (2)  <EQ*  1)  GOTO  200 
lOPTN  = 1 
110  CALL  TSRIE 

GOTO  (2007  500)  lOPTN 

C INPUT  INITIAL  HIGHWALL  / BENCH  DATA 

200  IF  (LER)  CALL  ERASE 
IF  (LER)  CALL  HOME 
IF  (MODE  »EQ*  4)  GOTO  209 

C OFFER  THE  USER  THE  OPTION  OF  USING  INITIAL  DATA 

C ENTERED  FOR  THE  PREVIOUSLY  DESCRIBED  ALTERNATIVE  - 

C IF  LUG  > 1 

WRITE  (LUT»  7000)  (ALTN  (LUO»  J)»  J = I7  4) 

IF  (LUO  ♦EQ*  1)  GOTO  209 
IF  (NHBP  (LUO  - 1)  ♦EQ*  0)  GOTO  209 
WRITE  (LUTj  1015)  (ALTN  (LUO  - 1>  J),  J = 1j  4) 

READ  (LUTy  7900)  IANS 

IF  (IANS  .NE.  2HYE)  GOTO  209 

C SET  INITIAL  DATA  TO  PREVIOUSLY  DESCRIBED  DATA 

DO  205  I = I7  NHBP  (LUO  ~ 1) 

HWSLl  (LUOy  I)  = HWSLI  (LUO  - ly  I) 

HWHT  (LUOy  I)  = HUHT  (LUO  - ly  I) 

BENWI  (LUOy  1)  = BENUI  (LUO  - ly  I) 

205  BENLEN  (LUOy  I)  = BENLEN  (LUO  - ly  I) 

NHBP  (LUO)  = NHBP  (LUO  - 1) 

SPCC  (LUO)  = Spec  (LUO  - 1) 

GOTO  300 

209  lOPTN  = 1 

210  CALL  TSIHB 

IF  (NHBP  (LUO)  cEQ*  0)  RETURN 
IF  (lOPTN  *EQ*  2)  GOTO  500 

C INPUT  FINAL  SLOPES  : IPTR  = 1 ->  GRAPHIC  MODE 

C IPTR  = 2 ->  NON-GRAPHIC  MODE 

300  IF  (♦NOT*  LER)  GOTO  350 
CALL  ERASE 
CALL  HOME 
WRITE  (LUTy  3000) 

310  READ  (LUTy  jfc ) IPTR 

IF  (IPTR  ♦GE*  1 *AND<  IPTR  <LE*  2)  GOTO  (330y  350)  IPTR 
WRITE  (LUTy  1000) 

GOTO  310 

C GRAPHIC  MODE 

330  CALL  TSIF6 

IF  (LER)  CALL  ERASE 
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IF  (LER)  CALL  HOME 
IF  (IHB  *EQ*  0)  GOTO  500 
GOTO  500 

C NON  - GRAPHIC  MODE 

350  CALL  TSIFN 

IF  (IHB  ♦EQ*  0)  GOTO  500 

C USER  SELECTION  ->  EBIT  OPTION 

500  IF  (LER)  CALL  ERASE 
IF  (LER)  CALL  HOME 
WRITE  (LUT?  5000) 

510  READ  (LUT»  t)  IPTR 

IF  (IPTR  .GE.  0 <AND*  IPTR  *LE.  8) 

> GOTO  (800>  750j  550>  515»  600>  700»  200>  300f  511) 

> IPTR  + 1 
WRITE  (LUT»  1000) 

GOTO  510 

C EDIT  THE  COST 

C GRADING  COSTS 

511  WRITE  (LUT>  7901)  COGO 

512  READ  (LUT>  t ) COGO 

IF  (COGO  ♦6E.  0)  GOTO 
WRITE  (LUT>  1000) 

GOTO  512 

513  IF  (MODE  ♦EQ*  4)  GOTO 
lOPTN  = 2 
LUOTMP  = LUO 
DO  514  LUO  = If  LUOTMP 
CALL  TSST 

514  CONTINUE 
LUO  = LUOTMP 
GOTO  500 

C EDIT  SPOIL  PILE  CONFIGURATION  CODE 

515  lOPTN  = 2 
GOTO  210 

C EDIT  REHANDLE  DATA 

550  IF  (RGENDE  (2)  *EQ*  1)  GOTO  500 
lOPTN  = 2 
GOTO  110 

C SELECTIVE  CHANGES  TO  INITIAL  HI6HWALL  / BENCH  DATA 

600  CALL  TSSCI 
GOTO  500 


OF  GRADING  OOERBURDEN?  AND  RE-COMPUTE 
FOR  ALL  ALTERNATIVES  CURRENTLY  DEFINED 

513 

500 


C SELECTIVE  CHANGES  TO  FINAL  SLOPE  VALUES 

700  CALL  TSSCF 
GOTO  500 

C DISPLAY  SUMMARY  TABLE 

750  IF  (*NOT*  LER)  GOTO  780 
CALL  ERASE- 
CALL  HOME 
WRITE  (LUT»  7500) 

760  READ  (LUT»  IPTR 

IF  (IPTR  <GE.  1 .AND*  IPTR  *LE.  2 ) GOTO  (770?  780) 
WRITE  (LUT?  1000) 

GOTO  760 


C SUMMARY 

770  CALL  TSXST 
GOTO  500 


TABLE  WITH  X-SECTIONAL  DISPLAY 


IPTR 
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0223 

0224 

0225 

0226 

0227 

0228 

0229 

0230 

0231 

0232 

0233 

0234 


0271 

0272 

0273 

0274 

0275 

0276 

0277 
027S 


C SUMMARY  TABLE  WITHOUT  X-SECTIONAL  DISPLAY 

780  WRITE  (LUTj  7800) 

790  READ  (LUT^  7900)  IANS 

IF  (IANS  ♦EQ*  2HTT  ♦OR*  IANS  2HLP)  GOTO  795 

WRITE  (LUTf  1000) 

GOTO  790 

795  IF  (IANS  *EQ*  2HLP)  LUL  = 6 

IF  (IANS  2HTT)  LUL  = LUT 

lOPTN  = 1 
CALL  TSST 
GOTO  500 

C tt  DONE  tt  UPDATE  INFORMATION  AND  RETURN 


0235 

800 

IF 

(MODE 

♦EO*  4)  GOTO  900 

0236 

lOPTN  ^ 

= 

! 

0237 

CALL  T: 

SST 

0238 

900 

RETURN 

' 

0239 

C 

FORMAT  statements: 

0240 

1000 

FORMAT 

X 

m 

??  ERROR  ♦ RE-INPUT  YOUR  VALUE  ->  _■) 

0241 

C 

0242 

1015 

FORMAT 

(/5X 

•USE  SAME  INITIAL  DATA  AS  FOR  MA2'  ? _•) 

0243 

C 

0244 

3000 

FORMAT 

(/5X 

• READY  TO  INPUT  FINAL  SLOPES* “/ 

0245 

> 

5X" 

1 ->  GRAPHIC  MODEVj 

0246 

> 

5X‘ 

2 ->  NON  - GRAPHIC  MODE'/» 

0247 

5X“ 

ENTER  YOUR  SELECTION  ->  -*) 

0248 

C 

0249 

5000 

FORMAT 

(5X" 

ttt  EDIT  OPTIONS  tttW/ 

0250 

5X* 

0 ->  EXIT  FROM  THIS  LAND  USE  OPTION"// 

0251 

> 

5X" 

1 ->  DISPLAY  SUMMARY  TABLE  OF  VOLUME  AND  COST "IX 

0252 

+ • CALCULATIONS*// 

0253 

> 

5X" 

2 ->  EDIT  REHANDLE  DATA  L NOT  FOR  OPENING  CUT  3'// 

0254 

> 

5X" 

3 ->  EDIT  THE  SPOIL  PILE  CONFIGURATION  CODE*// 

0255 

> 

5X- 

4 ->  SCHEDULE  SELECTIVE  CHANGES  TO  INITIAL*/ 

0256 

> 

5X‘ 

HIGHWALL  / BENCH  DATA*// 

0257 

> 

5X' 

5 ->  SCHEDULE  SELECTIVE  CHANGES  TO  FINAL  SLOPES*// 

0258 

> 

5X“ 

6 ->  RE  - INPUT  ALL  INITIAL  HIGHWALL  / BENCH  DATA*// 

0259 

5X* 

7 ->  RE  - INPUT  ALL  FINAL  SLOPE  VALUES*// 

0260 

> 

5X' 

8 ->  EDIT  THE  COST  OF  GRADING  OVERBURDEN*/ 

0261 

> 

5X“ 

AND  RE-COMPUTE  ALL  COSTS  FOR  ALL  LAND*/ 

0262 

> 

5X* 

USE  OPTIONS  CURRENTLY  DESCRIBED*// 

0263 

5X" 

FNTER  YOUR  SELECTION  ->  >*) 

0264 

C 

0265 

7000 

FORMAT C/5X* 

tt  TRUCK  AND  SHOVEL  SEGMENT  - "4A2*  ALTERNATIVE 

0266 

7500 

FORMAT 

(5X" 

tt  DISPLAY  SUMMARY  TABLE  ttW/ 

0267 

> 

5X" 

1 ->  PRESENT  CROSS  - SECTIONAL  VIEW  OF  GRADED*/ 

0268 

5X" 

SPOILS  WITH  SUMMARY  TABLE*// 

0269 

5X' 

2 ->  PRESENT  SUMMARY  TABLE  ONLY  *// 

0270 

> 

5X“ 

ENTER  YOUR  SELECTION  ->  _*) 

C 


7800  FORMAT  (5X“  DISPLAY  ON  TERMINAL  (TT)  OR  LINE  PRINTER  (LP)  ? - " ) 


7900  FORMAT  (A2) 

7901  FORMAT  (SX'CURRENT  COST  OF  GRADING  SPOILS  IS 


>“F5*2j 1X» 


•CENTS/CUBIC  YD<.  V, 

•ENTER  THE  NEW  COST  FOR  GRADING  SPOILS 


-•  ) 
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0279  C 

0280  END 

0281  END$ 
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0001 

FTN4 

0002 

SUBROUTINE  TSIFG 

0003 

C 

TRUCK  AND  SHOVEL  t INPUT  FINAL  SLOPES  - 

GRAPHIC  MODE 

0004 

C 

0005 

C 

LEOEL  3 

0006 

C 

0007 

C 

FINAL 

SLOPES  DESIRED  ON  THE  HIGHWALLS  ARE  ENTERED.  CROSS- 

0008 

C 

SECTIONAL  DISPLAYS  OF  THE  MINIMUM  SLOPE  REQUEST?  SUGGESTED 

0009 

C 

BENCH 

ADJUSTMENTS  TO  ACCOMODATE  A USER'S  SLOPE  REQUEST?  AND 

OOlO 

C 

THE  FINAL  SLOPE  VALUE  ARE  DISPLAYED. 

0011 

C 

0012 

C 

TSIFG  IS  ACCESSED  BY  TSGE  AND  SWAPPED  IN  BY  PROGRAM  TSIFX 

0013 

C 

0014 

C 

THE 

CALLING  SEQUENCE  IS  ; CALL  TSIFG 

0015  , 

C 

0016  * 

C 

TSIFG  SCHEDULES  THE  SUBROUTINES  : 

0017 

C 

0018 

C 

ANMOD 

<TCS) 

0019 

C 

BELL 

(TCS) 

0020 

C 

DASHA 

(TCS) 

0021 

C 

DRAWA 

(TCS) 

0022 

C 

DRWRL 

(TCS) 

0023 

C 

ERASE 

(TCS) 

0024 

c 

HOME 

(TCS) 

0025 

c 

INITT 

(TCS) 

0026 

c 

lOWAT 

(TCS) 

0027 

c 

MOVAB 

(TCS) 

0028 

c 

MOVEA 

(TCS) 

0029 

c 

MOVRL 

(TCS) 

0030 

c 

SWNDO 

(TCS) 

0031 

c 

VWNDO 

(TCS) 

0032 

c 

SPOLU 

(SYS) 

0033 

c 

DVN 

(CLAIM) 

0034 

c 

TSDBR 

(CLAIM) 

0035 

c 

TSSCK 

(CLAIM) 

0036 

c 

TSXBA 

(CLAIM) 

0037 

c 

TSXFS 

(CLAIM) 

0038 

c 

0039 

c 

TSIFG  ACCESSES  THE  DATA  FILE  : TSRFS 

0040 

c 

0041 

c 

THE 

LOCAL 

VARIABLES  ARE  t 

0042 

c 

0043 

c 

BENR 

->  BENCH  REMOVED 

0044 

c 

CDTR 

->  conversion:  degrees  to  radians 

0045 

c 

FMT  (INTEGER)  ->  MASTER  FORMAT  ARRAY 

0046 

c 

FMTl 

(INTEGER)  ->  FORMAT  ARRAY  FOR  CURRENT 

LUO 

0047 

c 

IOC 

->  ORIENTATION  CODE  (SEE  DVN) 

0048 

c 

ISC 

->  SIZE  CODE  (SEE  DVN) 

0049 

c 

LBN 

->  LIMITING  BENCH  NUMBER 

0050 

c 

NDP 

->  NUMBER  OF  DECIMAL  PLACES  (SEE  DVN) 

0051 

c 

RFS  ( 

INTEGER)  ->  RECOMMENDED  FINAL  SLOPES 

(INTIAL) 

0052 

c 

SLMAX 

->  MAXIMUM  REQUESTABLE  SLOPE 

0053 

c 

SLMIN 

->  MINIMUM  REQUESTABLE  SLOPE 

0054 

c 

SLMINA  ->  MINIMUM  REQUESTABLE  SLOPE  BASED 

ON  BENCH  ABOVE 
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0055 

0056 

0057 

0058 

0059 

0060 
0061 
0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 
0081 
0082 

0083 

0084 

0085 

0086 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 
0101 
0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


C 8LHINB  ->  HINIMUM  REQUL’STABLE  SLOPE  BASED  ON  BENCH  BELOW 

C TSRFS  ~>  ID  SEGHENT  FOR  FILE 

C WBB  “>  WIDTH  OF  BENCH  BELOW 

C XEXT  ~>  X EXTENT 

C XSWFH  ->  CROSS-SECTIONAL  WIDTH  OF  FINAL  HIGHWALL 

C XSWIH  ->  CROSS-SECTIONAL  WIDTH  OF  INITIAL  HIGHWALL 

C 

C THIS  ROUTINE  WAS  WRITTEN  BY  GREEN 
C 

C CLAIM  RELEASE  1*0  - APRIL  if  1980 

c 

C TEKTRONIX  COMMON 

C i 

COMMON  ITEK  <45) 

C 

C LOGICAL  UNITS  AND  COMMON  LOCATION 

C 

COMMON  I ARRY ( 5 ) » I ARY2 ( 5 ) y LER » LUF  y LUL 
C 

C POINTERS 

C 

COMMON  EXIT  y lANM ( 3 ) y ICLI ( 2 ) y IGEN ( 3 ) y IGRW ( 5 ) 

COMMON  lOPTN  yI0UR(7)yIHB  y ISOC ( 6 ) y ISUB ( 8 ) 

COMMON  ISUR(6) y 1I0P(9) y IUEG(2) yLEXIT  yLUO 
COMMON  MODE  yNANM  yNCLI  yNGEN  yNGRW 

COMMON  NOUR  yNSECTS  yNSOC  yNSUB  yNSUR 

COMMON  NTOP  tNU  yNUEG 

C 

C GRADING  PARAMETERS 

c, 

COMMON  AREA ( 5 ) y BENLEN ( 5 y 1 0 ) y BENW I ( 5 y 1 0 ) y COGO  y GCPA  < 5 ) 

COMMON  SPCC  < 5 ) y HUHT ( 5 y 1 0 ) y HWSL I ( 5 y 1 0 ) y NHBP ( 5 ) y PCEQ 1 9 ( 4 ) 
COMMON  BENWF(5y 10) y REHCPY < 5 ) y REHOOL ( 5 ) y HWSLF < 5y 10 ) y USR 
C 

C CATEGORY  TEXT 

C 

COMMON  ANIM(23y 13) yCLMA(13y 13) yGDES(15y 13) yGWHY(22y 13) 
COMMON  00BD(llyl3)ySBSL(13)y  SCEC ( 33 y 1 3 ) y SWHY ( 44 y 1 3 ) 

COMMON  TPSL(49yl3) yOGTA<15y 13) 

C 

C EXPECTATION  VALUES 

C 

COMMON  ANIMAL<13y6) yCLlMAT(8y6) yGENDES(8y6) yGRWHYD(19y6) 
COMMON  0VRBDN(28y6) yS0CECN(29y6) ySUBS01(30y6) ySURHYD(23y6) 
COMMON  T0PS0I(33y6) y VE6ETA(10y6) 

C 

C CATEGORY  RESPONSES 

C 

COMMON  RANIMA(3) yRCLlMA(2) yRGENDE(3) yRGRWHY<5) 

COMMON  R0VRBD(7y 10) yRS0CEC(6) y RSUBSO < 8 ) y RSURHY ( 6 ) 

COMMON  RT0PS0<9) yRVE6ET(2) 

C 

C FEASIyTECONyOPUSE  SUBSYSTEM  PARAMETERS 

C 

COMMON  CAAHM  y CABAH  y CABFN  < 3 ) y CABFP ( 3 ) y CABHM 
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0111 

0112 

0113 

0114 

0115 

0116  C 

0117 

0118 

0119 

0120 
0121 
0122 

0123 

0124 

0125  C 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133  C 

0134 

0135  C 

0136  C 

0137 

0138  C 

0139 

0140 

0141  C 

0142 

0143 

0144 

0145  C 

0146 

0147 

0148  C 

0149  C 

0150  C 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158  C 

0159  C 

0160  C 

0161 
0162 

0163 

0164 

0165 

0166 


COMMON  C ABS ( 2 ) j C AC  y CACP  y C ADF  y C ADH 

COMMON  CADS  y CAEAF  y CAHSAF  y CAHSTS  y CAIP 

COMMON  CAR3FC  y CASF  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y FAOG ( 5 ) y PFSTSP  y PFAC  y RCLTEC  < 29  y 34 ) 

COMMON  TCAR<5) y THICK(IO) yTHKTSyTTL(40) 


INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 


EXI T y CLMA  y GOES  y 6UH Y y OVBD  y SBSL 
SCEC  y SWH Y y TPSL  y OGT A y ANI M 
CL 1 MAT  y 6ENDES  y GRWH YD  y OOREDN 
SOCECN  y SUBSOI y SURHYD  y T OPSOI 
OEGETAy ANIMAL 

RCL I MA y RGENDE y RGRWH Y y RGORED y RSOCEC 
RSUESO  y RSURHY  y RTOPSO  y ROEGET  y RANIMA 
RCLTECyTTL 


INTEGER  COMMON  (1) 
EQUIVALENCE  (COMMON  <l)y 


EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 


(lARRY  <l)y 
(IARY2  <l)y 
(IARY2  (2)y 
(IARY2  (3)y 
(IARY2  (4)y 


ITEK  (1)) 
LUT  ) 

ISTRK) 

ISECT) 

ICODE) 

LEN) 


LOGICAL  LER 


COMMON  /ALTRN/  ALTN 
DIMENSION  RFS  (10) 

INTEGER  ALTN(6y4) yFMT(5y6) y TSRFS ( 3 ) y F MTl ( 6 ) 

DATA  FMT/2H(ly2H(ly2H(2y2H(3y2H(4y2H0Fy2H/y  y2H/y  y2H/y  y2H/y  y 
t 2H5*  y2H10y2H10y2H10y2H10y2Hl) y2HF5y2HF5y2HF5y2HF5y2H  y 
t 2H»iy2H.ly2H*ly2H*ly2H  y2H)  y2H)  y2H)  y2H)  / 


DATA  TSRFS/2HTSy2HRFy2HS  / 

DATA  lCR/15/ 

INITIALIZE  LOCAL  VARIABLES 
SLMAX  = 19*  ' 

IF  (LUO  ♦EQ*  1)  SLMAX  = 5,7 
CDTR  = 0*01745 
ISC  = 4 
IOC  = 3 
NDP  = 2 

IF  (MODE  *EQ*  4)  GOTO  7 

READ  IN  THE  RECOMMENDED  FINAL  SLOPE  VALUES 

CALL  SPOLU ( LUF  y TSRFS  y 2 y 1 y I CR ) 

IF  (LUF  *LT*  0)  STOP 
DO  5 J J = 1 y 6 
5 FMTKJJ)  = FMT(LUOyJJ) 

READ(LUF yFMTl)  (RFS(J)y  J = ly  NHBP  (LUO)  ) 
CALL  SPOLU(LUF yTSRFS»2y2y ICR) 
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0167 

0168 

0169 

0170 

0171 

0172 

0173 

0174 

0175 

0176 

0177 

0178 

0179 

0180 

0181 

0182 

0183 

0184 

0185 

0186 

0187 

0188 

0189 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

0197 

0198 

0199 

0200 

0201 

0202 

0203 

0204 

0205 

0206 

0207 

0208 

0209 

0210 

0211 

0212 

0213 

0214 

0215 

0216 

0217 

0218 

0219 

0220 

0221 

AOOO 

W Am  JU.  4^ 


c 

C INITIALIZE  THE  SCREEN^  THEN  PRINT  ROUTINE  TITLE 

C 

7 CALL  INITT  (LUT) 

CALL  lOUAT  (45) 

IF  (MODE  ♦NE*  4) 

>WR1TE  (LUT>  1000)  (ALTN  (LUOy  J)»  J = 1,  4) 

IF  (MODE  ♦EQ*  4)  WRITE  (LUT,  1005) 

C 

C INITIATE  LOOP 

C 

10  IHD  = 1 

SLMINB  =1* 

GOTO  20 
C 

C DETERMINE  THE  MINIMUM  REQUESTABLE  SLOPE  BASED  ON  BENCH 

C 

15  CALL  TSSCK  (BENWF  (LUO,  IHB  -1),  HWSLI  (LUO,  IHB), 

♦ HWHT  (LUO,  IHB),  SLMINB) 

C 

C DETERMINE  THE  MINIMUM  REQUESTABLE  SLOPE  BASED  ON  BENCH 

C 

20  CALL  TSSCK  (BENWI  (LUO,  IHB),  HWSLI  (LUO, IHB), 

♦ HWHT  (LUO,  IHB),  SLMINA) 

C 

C DETERMINE  THE  MINIMUM  REQUESTABLE  SLOPE 

C 

SLMIN  = AMAXl  (SLMINA,  SLMINB) 

C 

C DETERMINE  THE  LIMITING  BENCH  NUMBER 

C 

LBN  = IHB 

IF  (SLMINA  *LT*  SLMINB)  LBN  = IHB  - 1 
C 

C SET  THE  WINDOWS 

C 

IF  (IHB  *EQ*  1)  WBB  = BENWI  (LUO,  IHB) 

IF  (IHB  *GT*  1)  WBB  = BENWF  (LUO,  IHB  ~ 1) 

XSWIH  = HWHT  (LUO,  IHB)  / TAN  (HWSLI  (LUO,  IHB)  t CDTR) 

XEXT  = WBB  T XSWIH^T  BENWI  (LUO,  IHB) 

XSWFH  = HWHT  (LUO,  IHB)  / TAN  (SLMIN  t CDTR) 

CALL  OWNDO  (0*,  XEXT  , -20.,  XEXT  / 5*) 

C 

IF  (HWHT  (LUO,  IHB)  T 30*  .GE*  XEXT  / 5*) 

>CALL  OWNDO  (0*,  XEXT  , -20*,  HWHT  (LUO,  IHB)  + 30*) 

C 

CALL  SWNDO  (10,  440,  500,  220) 

C 

CALL  MOOAB  (10,  730) 

CALL  ANMOD 
WRITE  (LUT,  1010) 

CALL  MOVEA  (0*,  0.) 

C 

C DRAW  THE  INITIAL  DATA 

C 

CALL  DRAWA  (WBB,  0») 
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IHB-1 • 


IHB" 


0223 

0224 

0225 

0226 

0227 

0228 

0229 

0230 

0231 

0232 

0233 

0234 

0235 

0236 

0237 

0238 

0239 

0240 

0241 

0242 

0243 

0244 

0245 

0246 

0247 

0248 

0249 

0250 

0251 

0252 

0253 

0254 

0255 

0256 

0257 

0258 

0259 

0260 
0261 
0262 

0263 

0264 

0265 

0266 

0267 

0268 

0269 

0270 

0271 

0272 

0273 

0274 

0275 

0276 

0277 

0278 


CALL  DRAUA  <W8B  + XSWIH^  HUNT  <LU0»  IHB)) 
CALL  DRAWA  (XLXTy  HWHf  (LU0»  IHB)) 

CALL  DASHA  (XLXT,  54) 

CALL  DASHA  (WBBj  0*r  54) 


DRAW  THE  MINIMUM  REQUESTABLE  SLOPE 


IF  <LBN 
50  CALL  MOOEA 
CALL  DASHA 
CALL  MOOEA 
GOTO  75 


♦ECn  IHB)  60>  50 

<0*  » 0. ) 

(XSWFHy  HWHT  <LUO> 

(0*  y 0* ) 


IHB)r  54) 


60  CALL  MOUEA 
CALL  DASHA 


(XEXTf  HWHT  <LU0j  IHB)) 
(XEXT  - XSWFH?  0*,  54) 


LABEL  THE  MINIMUM  SLOPE  REQUEST 


C 

c 

c 


75  CALL 

MOORL 

(40?  0) 

CALL 

DRWRL 

(0?  50) 

CALL 

DON  (S 

LMIN?  ISC? 

CALL 

MOORL 

(-3?  0) 

CALL 

DRWRL 

(0?  3) 

CALL 

DRWRL 

(3?  0) 

CALL 

DRWRL 

(0?  -3) 

CALL 

DRWRL 

(-3?  0) 

lOCy  NDP) 


LABEL  THE  UPPER  BENCH  WIDTH 


CALL  MOVEA  (WBB  + 
IF  (BENWI  (LUOy 


XSWIHy  HWHT  <LUO>  IHB)) 
IHB)  ♦LT*  XEXI  / 3*)  80y 


90 


80  CALL  MOOEA 
CALL  DRWRL 
CALL  MOORL 
CALL  DRWRL 
CALL  MOORL 
CALL  DRWRL 
CALL  MOVRL 
IOC  = 1 
CALL  DON  ( 
GOTO  100 


<XEXT  - (BENWI  (LUO>  IHB)  / 2*) y HWHT 
<6»  6) 

<-6>  -6) 

<-6j  6) 

(6»  -6) 

<0?  15) 

(~15»  10) 

BENWI  (LUOf  IHB)?  ISC?  IOC?  NDP) 


C 


(LUO?  IHB)  ) 


90  CALL  DRAWA  (WBB  + XSWIH?  HWHT  (LUO?  IHB)  + 10*) 

CALL  MOOEA  (WBB  + XSWIH?  HWHT  (LUO?  IHB)  T 5*) 

CALL  DRAWA  (WBB  + XSWIH  + BENWI  (LUO?  IHB)  / 3*? 
♦ HWHT  (LUO?  IHB)  +5*) 

IOC  = 1 

CALL  DON  (BENWI  (LUO?  IHB)?  ISC?  IOC?  NDP) 

CALL  DRAWA  (XEXT?  HWHT  (LUO?  IHB)  T 5*) 

CALL  MOOEA  (XEXT?  HWHT  (LUO?  IHB)  + 10*) 

CALL  DRAWA  (XEXT?  HWHT  (LUO?  IHB)) 

C 

C LABEL  THE  LOWER  TERRACE  WIDTH 

C 

100  CALL  MOOEA  (0*  ? 0* ) 
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0279 

0280 
0281 
0282 

0283 

0284 

0285 

0286 

0287 

0288 

0289 

0290 

0291 

0292 

0293 

0294 

0295 

0296 

0297 

0298 

0299 

0300 

0301 

0302 

0303 

0304 

0305 

0306 

0307 

0308 

0309 

0310 

0311 

0312 

0313 

0314 

0315 

0316 

0317 

0318 

0319 

0320 

0321 

0322 

0323 

0324 

0325 

0326 

0327 

0328 

0329 

0330 

0331 

0332 

0333 

0334 


CALL 

DRAWA 

(0,?  -20. 

) 

IF  (WBB 

.LT.  XEXT 

/ 3 

.)  110 

110 

CALL 

NOOEA 

(WBB  / 2. 

? 0 ♦ 

) 

CALL 

DRWRL 

( —6  ? — 6 ) 

CALL 

NOORL 

(6?  6) 

CALL 

DRWRL 

( 6 ? — 6 ) 

CALL 

NOORL 

(-6?  6) 

CALL 

DRAWA 

(WBB  / 2. 

? -5 

♦ ) 

CALL 

DRWRL 

<10?  0) 

CALL 

DON  (WBB?  ISC? 

IOC? 

NDP ) 

CALL 

NOOEA 

(WBB?  0.) 

GOTO 

130 

120 

CALL 

NOOEA 

(0.?  -5.) 

CALL 

DRAWA 

(15.?  -5. 

) 

CALL 

DON  (WBB?  ISC? 

IOC? 

NDP ) 

CALL 

DRAWA 

(WBB?  -5. 

) 

CALL 

NOOEA 

(WBB?  -10 

♦ ) 

CALL 

DRAWA 

(WBB?  0.) 

C LABEL  THE  INITIAL  HI6HWALL  SLOPE 

C 

130  CALL  MOORL  <20,  10) 

CALL  DON  (HWSLl  <LUQ,  IHB)f  ISC,  IOC?  NDP) 
CALL  MOORL  <0,  3) 

CALL  DRWRL  (0,  3) 

CALL  DRWRL  <3>  0) 

CALL  DRWRL  (0,  -3) 

CALL  DRWRL  <-3,  0) 

C 

C LABEL  THE  TOTAL  X-SECTIONAL  WIDTH  AND  HEIGHT 

C 

CALL  MOOEA  <0*,  -15*) 

CALL  DRAWA  (WBB  + 10.,  -15*) 

CALL  DON  (XEXfy  ISC,  lOCr  NDP) 

CALL  DRAWA  (XEXT f ~ 15*) 

CALL  MOOEA  (XEXT?  -20.) 

CALL  DRAWA  <XEXT>  0*) 

CALL  NOOEA  (XEXTj  HWHT  (LU0»  IHB)  / 2*) 

CALL  DRWRL  <15y  0) 

CALL  MOORL  <10»  -20) 

IOC  = 3 

CALL  DON  (HWHT  (LUO,  IHB) y ISC»  lOCf  NDP) 

C 

C INPUT  THE  USER'S  SLOPE  REQUEST 

C 

CALL  HOOAB  <10?  400) 

CALL  ANNOD 

WRITE  (LUT?  1015)  IHB 
CALL  BELL 

IF  (NODE  *EQ*  4)  GOTO  150 
WRITE  (LUT?  1020)  RFS  (IHB) 

GOTO  160 

150  SLNAX  =:  HWSLl  (LUO?  IHB) 

160  WRITE  (LUT?  1030)  SLNIN?  LBN?  SLNAX?  IHB 
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0335 

C 

0336 

170 

READ  (LUTj  USR 

0337 

C 

0338 

C 

TEST  THIS  SLOPE  VALUE 

0339 

C 

0340 

IF  (USR  *6E*  SLMIN)  GOTO  200 

0341 

C 

0342 

C 

DRAW  CROSS  - SECTION  OF  SUGGESTED  BENCH  ADJUSTMENTS 

0343 

C 

0344 

CALL  TSXBA 

0345 

C 

0346 

C 

START  OVER  OR  QUIT 

0347 

C 

0348 

IF  (IHB  ^EQ*  0)  GOTO  600 

0349 

CALL  ERASE 

0350 

CALL  HOME 

0351 

IF  (IHB  *EQ»  1)  10,  15- 

0352 

C 

0353 

C 

TEST  USR  FOR  TOO  GREAT  A MAGNITUDE 

0354 

C 

0355 

200 

IF  (USR  *LE»  SLMAX)  GOTO  210 

0356 

WRITE  iLUJy  1040)  SLMAX 

0357 

GOTO  170 

0358 

C 

0359 

C 

USER  INPUT  VALUE  IS  OK*  UPDATE  INFORMATION 

0360 

C 

0361 

210 

HUSLF  (LUO>  IHB)  = USR 

0362 

CALL  TSDBR  (HWHT  (LUO,  IHB),  HWSLI  (LUO,  IHB), 

0363 

♦ 

HWSLF  (LUO,  IHB),  BENR) 

0364 

IF  (IHB  *EQ*  1)  GOTO  211 

0365 

BENWF  (LUO,  IHB  - 1 ) = BENWF  (LUO,  IHB  - 1)  - BENR 

0366 

211 

BENWF  (LUO,  IHB)  = BENWI  (LUO,  IHB)  - BENR 

0367 

c 

0368 

c 

DRAW  X-SECTION  OF  GRADED  SLOPE  AND  GET  THE  NEXT  PAIR 

0369 

c 

0370 

CALL  TSXFS 

0371 

IHB  = IHB  + 1 

0372 

IF  (IHB  *LE4  NHBP  (LUO))  GOTO  15 

0373 

RETURN 

0374 

c 

V 

0375 

c 

USER  WANTS  OU’r  ~>  RESET  FINAL  DATA  TO  INITIAL  DATA 

0376 

c 

0377 

600 

DO  605  1=1,  NHBP  (LUO) 

0378 

BENWF  (LUO,  I)  = BENWI  (LUO, I) 

0379 

605 

HWSLF  (LUO,  I)  = HWSLI  (LUO,  I) 

0380 

RETURN 

0381 

c 

0382 

c 

FORMAT  STATEMENTS 

0383 

c 

0384 

1000 

FORMAT (15X' INPUT  FINAL  SLOPES  : MA2*  ALTERNATIVE") 

0385 

c 

0386 

1005 

FORMATdSX"  INPUT  FINAL  SLOPES  ") 

0387 

c 

0388 

c 

0389 

1010 

FORMATC "MINIMUM  REQUESTABLE  SLOPE") 

0390 

c 
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0391 

0392 

0393 

0394 

0395 

0396 

0397 

0398 

0399 

0400 

0401 

0402 

0403 

0404 


1015  F0RMAT(10Xy20(  •-•')»  "HIGHWALL  # ■I2j20<“-")) 

C 

1020  F0RMAT(/*Wt:  RECOMMEND  A FINAL  SLOPE  VALUE  OF  ■F7.2''  DEGREES* ') 

C 

1030  FORMAK 

>7X-THE  CURRENT  MINIMUM  SLOPE  OF  •F7*2"  DEGREES  WILL  RESULT“/> 
>7X“IN  A TERRACE  ♦ 'I2'  WIDTH  OF  ABOUT  ZERO**/? 

>7X*THE  MAXIMUM  REQUESTABLE  SLOPE  IS  ~>  "F8*2"  DEGREES*// 

*7X*INPUT  THE  FINAL  SLOPE  (DEGREES)  DESIRED  ON  HIGHWALL  *12*  ->  _*) 
C 

1040  F0RMAT(F7*2"??ERR0R  : MAXIMUM  SLOPE  EXCEEDED*  RE-INPUT  ->  -.*) 

C 

END 

END$ 
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8TSIFN  T=00004  IS  0^^  CR00015  USING  00070  BLKS  R=0000 


0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 

0053 

0054 


FTN4 

C 

C 

C LEVEL  3 


SUBROUTINE  TSIFN 

TRUCK  AND  SHOVEL  t INPUT  FINAL  SLOPES 


(NON-GRAPHIC  NODE: 


C 

C TSIFN  INPUTS  FINAL  SLOPES  IN  THE  “NON-GRAPHIC"  MODE  - THAT  IS,  N( 
C CROSS-SECTIONAL  VIEWS  OF  THE  DATA  ARE  AVAILABLE*  A TABLE  OF 
C RECOMMENDED  FINAL  SLOPE  VALUES  ARE  PRESENTED  TO  THE  USER,  WHO  HA< 
C THE  OPTION  OF  IMPLEMENT ING  THEM  DIRECTLY,  OR  USING  HIS  OWN*  SHGUl 
C A USER  ENTERED  OR  RECOMMENDED  FINAL  SLOPE  VALUE  BE  LESS  THAN  THE 
C MINIMUM  REQUESTABLE  FINAL  SLOPE  VALUE,  THE  USER  IS  GIVEN  A 
C SUGGESTION  DESCRIBING  THE  BENCH  ADJUSTMENTS  NEEDED  TO  IMPLEMENT 
C THAT  SLOPE*  IF  THE  USER  EXITS  BEFORE  COMPLETING  THE  FINAL  SLOPE 
C DESCRIPTION,  THE  FINAL  SLOPES  ARE  SET  TO  THE  INITIAL  SLOPES*  ALL 
C SLOPE  VALUES  ARE  ADJUSTED  TO  THE  “HUNDRETHS"  PLACE* 

C 

C TSIFN  IS  ACCESSED  BY  TSIFG  AND  SWAPPED  IN  BY  PROGRAM  TSIFO 
C 


C THE  CALLING  SEQUENCE  IS  : CALL  TSIFN 

C 

C SUBROUTINES  SCHEDULED: 


C 


c 

ERASE 

(TCS) 

c 

HOME 

(TCS) 

c 

TSDBR 

(CLAIM) 

c 

TSRC 

(CLAIM) 

c 

TSSCK 

(CLAIM) 

c 

TSBLA 

(CLAIM) 

c 

SPOLU 

(SYS) 

C 

C LABEL  COMMON  DECLARATIONS  : 
C 

C ALTRN 

C 


C 

C 

C 

C 

C 

c 

c 

c 

c 


c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


LOCAL  variables: 

B1  ->  USER  DEFINED  BENCH  ‘1HB“  WIDTH 

B2  ->  USER  DEFINED  BENCH  “lHB-1*  WIDTH 

BENCHl  ~>  SUGGESTED  BENCH  “1HB~1“  WIDTH 

BENCH2  ->  SUGGESTED  BENCH  “1HB-1“  WIDTH  (TWO  BENCH  ADJUSTMEf 

BENR  ->  BENCH  REMOVED 

BMIN  ->  MINIMUM  BENCH  WIDTH 

FMT  ->  MASTER  FORMAT  ARRAY  FOR  FILE  READ  (INTEGER) 

FMTl  ->  FORMAT  STATEMENT  FOR  CURRENT  LUO  (INTEGER) 

IANS  ->  ANSWER  CELL 

lAVAL  ->  FLAG  FOR  DEFAULT  SLOPE  AVAILABILITY 

IDFALT  ->  SET  TO  2 FOR  INPUT  OF  DEFAULT  SLOPES 
LBN  ~>  LIMITING  BENCH  NUMBER 

NMB  ->  NUMBER  OF  BENCH  NEEDING  ADJUSTMENT  (2  BENCHES) 

NUMBR  ->  NUMBER  OF  BENCH  NEEDING  ADJUSTMENT  (1  BENCH  ONLY) 

SLMAX  ->  MAXIMUM  PERMISSIBLE  FINAL  SLOPE 

SLMIN  ->  MINIMUM  PERMISSIBLE  FINAL  SLOPE 

SLMINA  ->  MINIMUM  SLOPE  BASED  ON  BENCH  ABOVE  CURRENT  HIGHWAL 
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0055 

0056 

0057 

0058 

0059 

0060 

0061 

0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 

OOBl 

0082 

0083 

0084 

0085 

0086 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 

0101 

0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


C SLMIN8  ->  MINIMUM  SLOPE  BASED  ON  BENCH  BELOW  CURRENT  HIGHWALL 

C 

C DATA  FILES  ACCESSED  : TSRFS  c 

C 

C THIS  ROUTINE  WAS  WRITTEN  BY  EASTMAN  AND  EXTENSIVELY  MODIFIED  BY  GREEN* 
C 

C CLAIM  RELEASE  1*0  - APRIL  If  1980 

C 

C ====  = ========  = ====  = = ======  = ==  = ========  = ====  = ==  = ========  = =======.=  =:====  = =======:=====:=:===:======  = =====:============= 

c 

C TEKTRONIX  COMMON 

C 

COMMON  ITEK  (45) 

C 

C LOGICAL  UNITS  AND  COMMON  LOCATION 

C 

COMMON  1ARRY<5) y IARY2(5) jLER»LUFjLUL 
C 

C POINTERS 

C 

COMMON  EXIT  y I ANM ( 3 ) » ICLI ( 2 ) y IGEN ( 3 ) y IGRW ( 5 ) 

COMMON  lOPTN  yI0VR(7)ylHB  y IS0C(6) y ISUB(8) 

COMMON  ISUR<6) y 1T0P(9) y IVEG ( 2 ) y LEXIT  yLUO 
COMMON  MODE  yNANM  yNCLl  yNGEN  yNGRW 

COMMON  NOVR  yNSECTS  yNSOC  yNSUB  yNSUR 

COMMON  NTOP  yNU  yNVEG 

C 

C GRADING  PARAMETERS 

C 

COMMON  AREA ( 5 ) y BENLEN ( 5 y 1 0 ) y BENWI < 5 y 1 0 ) y COGO  y GCPA ( 5 ) 

COMMON  SPCCC5)  yHWHT(5y  10)  yHWSLK5y  10)  y NHBP  ( 5 ) y PCEQ19  ( 4 ) 

COMMON  BENWF(5y 10) yREHCPY<5) y REHVOL ( 5 ) y HWSLF ( 5 y 10 ) y USR 
C 

C CATEGORY  TEXT 

C 

COMMON  ANIM(23y 13) yCLMA(13y 13) y GDES( 15y 13) y GWHY(22y 13) 

COMMON  0VBD(llyl3)ySBSL(13)y  SCEC(33y 13) y SWHY(44y 13) 

COMMON  TPSL(49y 13) y VGTA(15y 13) 

C 

C EXPECTATION  VALUES 

C 

COMMON  ANIMAL(13y6) y CLIMAT ( 8 y 6 ) y 6ENDES ( 8 y 6 ) y 6RWHYD ( 19 y 6 ) 

COMMON  0VRBDN<28y6) y SOCECN ( 29 y 6 ) y SUBSOI ( 30 y 6 ) y SURHYD ( 23 y 6 ) 

COMMON  T0PS0I(33y6) y VEGETA ( 10 y 6 ) 

C 

C CATEGORY  RESPONSES 

C 

COMMON  RANIMA(3) yRCLIMA(2) yRGENDE(3) yRGRWHY(5) 

COMMON  R0VRBD(7y 10) yRS0CEC(6) y RSUBSO ( 8 ) y RSURHY ( 6 ) 

COMMON  RT0PSD<9) yRVEGET(2) 

C 

C FEASIyTECONyOPUSE  SUBSYSTEM  PARAMETERS 

C 

COMMON  CAAHMyCABAHyCABFN<3) yCABFP(3) yCABHM 
COMMON  CAES ( 2 ) y CAC  y CACP  y CADF  y CADH 
COMMON  CADS  y CAEAF  y CAHSAF  y CAHSTS  y CAI P 
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0111 

0112 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120 

0121 

0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 

0161 

0162 

0163 

0164 

0165 

0166 


COMMON  CAR3FC  y CASF » CASNC  r CSTES  > CSTRM 

COMMON  CSTRP  ? F AOG ( 5 ) 7 PFSTSP  t PFAC  7 RCLTEC  <29734) 

COMMON  TCAR<5) 7THICK(10) 7THKTS7TrL<40) 

INTEGER  EXI T 7 CLMA  7 GDES  7 GWH Y 7 OOBD  7 SBSL 
. INTEGER  SCEC  7 SWHY  7 TPSL  7 VGT A 7 ANIM 
INTEGER  CLIMAT7GENDES7GRWHYD7OORBDN 
INTEGER  SOCECN7SUBSOI7SURHYD7TOPSOI 
INTEGER  OEGETA7 ANIMAL 

I NTEGER  RCLIMA  7 RGENDE  7 RGRWH Y 7 ROORBD  7 RSOCEC 
INTEGER  RSUBS07RSURHY7RT0PS07R0EGE7  7RANIMA 
INTEGER  RCLTEC77TL 
INTEGER  COMMON  (1) 

EQUIVALENCE  (COMMON  (1)7  ITEK  (1)) 

EQUIVALENCE  (lARRY  (1)7  LUT) 

EQUIVALENCE  (IARY2  (D7  ISTRK) 

EQUIVALENCE  (IARY2  (2)?  ISECT) 

EQUIVALENCE  (IARY2  (3)7  ICODE) 

EQUIVALENCE  (IARY2  (4)7  LEN) 

LOGICAL  LER 
COMMON  /ALTRN/  ALTN 

INTEGER  ALTN(674) 7 FMT ( 5 7 6 ) 7 TSRFS ( 3 ) 7 FMTl ( 6 ) 

BATA  FM7 /2H ( 1 7 2H ( 1 7 2H ( 2 7 2H ( 3 7 2H ( 4 7 2H0F  7 2H/ 7 7 2H/ 7 7 2H/ 7 7 2H/ 7 7 
t 2H5*  72H1072H1072H1072H1072H1) 72HF572HF572HF572HF572H  7 

t 2H*l72H*l72H.l72H*l72H  72H)  72H)  72H)  72H)  / 

DATA  TSRFS/2HTS72HRF72HS  / 

DATA  ICR/15/ 

5 IF (LER)  CALL  ERASE 
IF  (LER)  CALL  HOME 

URITE(LUT7l000) 

IF  (MODE  *NE*  4)  GOTO  6 
IDFALT  = 2 
GOTO  60 

READ  IN  THE  DEFAULT  SLOPES  AND  PRESENT  THEM  TO  THE  USER 

6 CALL  SPOLU(LUF7TSRFS727l7lCR) 

IF(LUF*GE*0)  97  7 

7 WRITE(LUT78)  LUF 
READ(LUT7){J)  IAVAL 

IF(IAVAL*EQ*0)  RETURN 
GOTO  11 

9  DO  10  JJ  = I7  6 

10  FMTKJJ)  = FMT(LU07JJ) 

READ ( LUF  7 FMT 1 ) ( HUSLF ( LUO  7 J ) 7 J= 1 7 NHBP ( LUO ) ) 

11  CALL  SP0LU(LUF7TSRFS72727lCR) 

WRITE (LUT 7 12)  ( ALTN ( LUO  7 J ) 7 J=1 7 4 ) 

41  IF<IAVAL»NE*i)  437  42 

42  IDFALT  = 2 
GOTO  60 

43  WRITE(LUT744) 

DO  45  IHB  =1 7 NHBP (LUO) 

45  WRITE(LUT 746)  IHE7  HWSLF  (LUO7  IHB) 

50  WRITE(LUT751) 

READ(LUT7:«:)  IDFALT 

IF(IDFALT.LTM»0R»IDFALT.GT*2)  GOTO  50 
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0214 
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0218 
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0220 

0221 

JU.  aU 


60  IHP.  = 1 

SLMINB  = 1* 

GOTO  70 

C CALCULATE  THE  MINIMUM  SLOPE  BASED  ON  BENCH  '1HB-1‘ 

65  CALL  TSSCK(BENWF(LUOr IHB~1) » HWSLI ( LUO r IHB ) y HUHT ( LUO > IHB ) ySLMINB) 
C CALCULATE  THE  MINIMUM  SLOPE  EASED  ON  BENCH  'IHB' 

70  CALL  TSSCKCBENWI (LUOr IHB) y HWSLI ( LUO y IHB ) » HWH T < LUO j IHB ) » SLMINA ) 

C DETERMINE  THE  MINIMUM  SLOPE  AND  LIMITING  BENCH  NUMBER 

SLMIN=PLOAT(  IFIXCAMAXl  <SLMINAySLMINB):t:100*  + *01 ) )/100* 

LBN  IHB 

IF(SLMINA  *LT*  SLMINB)  LBN  = IHB  - 1 
C IF  IDFALT  = ly  WE  HAME  THE  SLOPE  IF  IDFALT  = 2y  WE  GET  IT 

C FROM  THE  USER 

IF  (IDFALT  *EQ*  1)  75y  80  ' 

75  USR  = HWSLF  (LUOy  IHB) 

GOTO  85 

80  WRITE  (LUTy  82)  IHBy  SLMINy  LBNy  IHB 
READ  (LUTy  t)  USR 
C TEST  USR  FOR  VALIDITY 

85  SLMAX=AMIN1(19*  y HWSLI ( LUO y IHB ) ) 

IF(LUO»EQ* 1 ) SLMAX=AMIN1 (5* 7y HWSLI (LUOy IHB) ) 

IF(M0DE»EQ*4)  SLMAX=HWSLI ( LUO y IHB ) 

SLMAX=FL0AT(IFIX(SLMAX:^:100*  ) )/100* 

IF(USR*GT.SLMAX)  GOTO  100 
IF(USR*LT.SLMIN)  120y  500 
C USR  IS  TOO  LARGE 

100  WRITE  (LUTy  101)  IHB 
READ  (LUTy  t)  IANS 

IF  (LER)  CALL  ERASE 
IF  (LER)  CALL  HOME 

IF  (IANS  ♦GE*  1*AND*  IANS  ♦LE*  3)  GOTO  (80y  5y  600)  IANS 
GOTO  100 

C USER  SLOPE  REQUEST  IS  TOO  SMALL 
120  WRITE  (LUTy  121)  IHBy  SLMIN 
READ  (LUTy  >tc)  IANS 

IF  (LER)  CALL  ERASE 
IF  (LER)  CALL  HOME 

IF  (IANS  ♦LT*  1 ♦OR*  IANS  *GT*  4)  GOTO  120 
GOTO  (80y  5y  400 y 600)  IANS 

C USER  WANTS  A SUGGESTION  THAT  WILL  ENABLE  US  TO  USE  USR 
C CALCULATE  A BENCH  WIDTH  THAT  WILL  ACCOMODATE  USR 

400  CALL  TSDBR  ( HWHT ( LUO y IHB ) y HWSLI ( LUO y IHB ) y USR y BMIN ) 

C IF  THE  MINIMUM  BENCH  REQUEST  IS  GREATER  THAN  BENCHES  “IHB*' 

C AND  “IHB  ~ i“y  AN  ADJUSTMENT  WILL  BE  REQUIRED  TO  BOTH  OF  THEM* 

C (THE  SAME  ISy  OF  COURSEy  TRUE  IF  BENCH  “IHB"  =-■  BENCH  “IHB  - 1") 

C OTHERWISEy  AN  ADJUSTMENT  TO  THE  LESSER  BENCH  WILL  DO  THE  JOE* 

IF  (IHB  *EQ*  1)  GOTO  455 

IF  (BENWI  (LUOy  IHB)  *EQ*  BENWF  (LUOy  IHB  - 1))  GOTO  475 
IF  (BENWI  (LUOy  IHB)  *GT*  BENWF  (LUOy  IHB  - 1))  425y  450 
C AN  ADJUSTMENT  TO  BENCH  “IHB  - 1“  IS  NEEDED 

425  IF  (BMIN  *GT*  BENWI  (LUOy  IHB))  GOTO  475 
NUMBR  = IHB  " 1 

BENCHl  = BENWI  (LUOy  IHB  - 1)  + (BMIN  - BENWF  (LUOy  IHB  - 1)) 

426  WRITE  (LUTy  428)  NUMBRy  BENWI  (LUOy  IHB  - l)y  BENCHl y USR 
WRITE (LUTy  481) 

READ  (LUTy  t)  IANS 
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0223 

0224 

0225 

0226 
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0271 

0272 
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0277 

0278 


1F<LER)  CALL  ERASE 
ir<LER)  CALL  HOME 

IFdANS  ♦LT*  1 *0R*  IANS  *GT*  5)  GOTO  426 
GOTO  (490y  510y  80»  5y  600)  IANS 
C AN  ADJUSTMENT  TO  BENCH  'IHB*  IS  NEEDED 

450  IF  <BMIN  ♦GT*  BENWF  (LUOy  IHB  ~ 1 ) ) 475y  455 
455  WRITE  (LUTy  428)  IHBy  BENWI  (LUOy  IHB)y  BMINy  USR 
WRITECLUTy  481) 

READ  (LUTy  IANS 

IF(LER)  CALL  ERASE 
IF(LER)  CALL  HOME 

IF  (IANS  ♦LT*  1 *0R*  IANS  *GT*  5)  GOTO  455 
NUMBR  = IHB 
BENCHl  = BMIN 

GOTO  <490y  510y  BOy  5y  600)  IANS 
C AN  ADJUSTMENT  TO  BOTH  BENCHES  •'IHB*'  AND  “IHB  - I"  IS  NEEDED 
475  BENCHl  = BMIN 

BENCH2  = BENWI  (LUOy  IHB  - 1)  + (BMIN  - BENWF  (LUOy  IHB  - 1)) 
NMB  = IHB  - 1 

WRITE  (LUTy  478)  NMBy  BENWI  (LUOy  IHB  - l)y  BENCH2y  IHBy 
> BENWI  (LUOy  IHB)y  BENCHl y IHB 

480  WRITE  (LUIy  481) 

READ  (LUTy  IANS 
IF(LER)  CALL  ERASE 
IF(LER)  CALL  HOME 

IF-^dANS  4LT*  1 *0R*  IANS  *GT.  5)  GOTO  480 
GOTO  (495y  520y  80y  5y  600)  IANS 
C MAKE  THE  ADJUSTMENT  TO  BENCH  “NUMBR'  y AND  ADJUST 
C BENCH  LENGTHS  FOR  SEMI-CIRCULAR  SPOILS 
490  IF  (Spec  .EQ*  2«)  GOTO  494 
IPTR  = 1 

CALL  TSBLA  (IPTR y NUMBR y BENCHl y PARAM2 ) 

494  BENWI  (LUOy  NUMBR)  = BENCHl 
GOTO  497 

C MAKE  THE  ADJUSTMENT  TO  BENCHES  “1HB“  AND  “IHB  - 1" 

495  IF  (Spec  ♦EQ*  2*)  GOTO  496 
IPTR  = 2 

CALL  TSBLA  dPT R y IHB y BENCHl y BENCH2 ) 

496  BENWI  (LUOy  IHB)  = BENCHl 
BENWI  (LUOy  IHB  - 1)  = BENCH2 

C WE  HAVE  TO  RECALCULATE  THE  WHOLE  SHEBANG  UP  TO  THIS  POINT 

497  CALL  TSRC  ( LUO y IHB y HWSLI y HWHT y HWSLF y BENWF y BENWI ) 

C UPDATE  INFORMATION  : CALCULATE  THE  BENCH  REMOVED  BY  USR 
500  HWSLF  (LUOy  IHB)  = USR 

CALL  TSDBR(HWHT(LUOy IHB) y HWSLI ( LUO y IHB ) y HWSLF ( LUO y IHB ) yBENR) 

IF  (IHB  tEQ*  1)  GOTO  505 

BENWF  (LUOy  IHB  - 1)  = BENWF  (LUOy  IHB  - 1 ) - BENR 
505  BENWF  (LUOy  IHB)  = BENWI  (LUOy  IHB)  - BENR 
IHB  = IHB  -f  1 

IF  (IHB  .LE*  NHBP  (LUO))  GOTO  65 
RETURN 

C INPUT  USER'S  BENCH  AD JUSTMENT ( S) 

510  WRITE  (LUTy  511)  NUMBR 
READ  (LUTy  t)  B1 

IF(LER)  CALL  ERASE 
IF(LER)  CALL  HOME 
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IF  <B1  ♦LT*  BENCHl)  GOTO  510 
BENCHl  = B1 
GOTO  490 

520  WRITE  (LUTy  511)  NMB 
READ  (LUT»  t)  hi 

IF(LER)  CALL  ERASE 
IF(LER)  CALL  HOME 
IF  <B1  ♦LT^  BENCH2)  GOTO  520 
BENCH2  = B1 

522  WRITE  (LOT?  511)  IHB 
READ  <LUf>  t)  B2 

IF  <B2  *LT*  BEMCHl)  GOTO  522 
BENCHl  = B2 
GOTO  495 

C USER  WANTS  TO  QUIT  AFTER  UNSUCCESSFUL  TRIES.  RESET  FINAL  DATA 
600  DO  605  IHB  = 1»  NHBP(LUO) 

BENWF  <LUO,  IHB)  = BENWI  (LUO>  IHB) 

605  HWSLF  (LUOy  IHB)  = HWSLI  (LUO?  IHB) 

RETURN 

C FORMAT  STATEMENTS 

1000  FORMAr(/?5X'X^)4c)#c  INPUT  FINAL  SLOPES  ttf//) 

8 FORMAT </?5X'TSRFS  OPEN  ERROR* 17//? 

)K5X"THE  DEFAULT  SLOPE  UALUES  ARE  UNAVAILABLE'/? 

5*:5X'ENTER  0 TO  EXIT?  1 TO  CONTINUE  ->  _') 

12  F0RMAT(/?5X'  t '4A2'  ALTERNATIVE  f) 

44  F0RMAT(/?5X'DEFAULT  SLOPES  :“/? 

*5X'HIGHWALL/BENCH  PAIR  DEFAULT  SLOPE  VALUE' 

)fc/?5X" •/) 

46  F0RMAT(13X?I2?10X'  '7X?F5.2) 

51  F0RMAT(/?5X'SELECT  ONE  OF  THE  FOLLOWING  :'/? 

)«C5X'1)  USE  THE  DEFAULT  VALUES'/? 

5{c5X'2)  I'LL  USE  MY  OWN  VALUES'/? 

3«(5X' ENTER  1 OR  2 ->  _') 

82  F0RMAT(/?5X'THE  MINIMUM  REQUESTABLE  SLOPE  FOR  HIGHWALL  #='I2?/? 

'F5.2'  DEGREES.  THIS  SLOPE  WILL  REDUCE  THE  WIDTH  OF'/? 
)K5X'BENCH  # '12'  TO  ABOUT  ZERO.*//? 

)tc5X' INPUT  THE  FINAL  SLOPE  FOR  HIGHWALL  ^ *12*  ->  _') 

101  F0RMAT(/?5X'ERR0R  ->  SLOPE  REQUESTED  FOR  HIGHWALL  '12'  TOO  LARGE'/ 
)t:5X'Y0U  MAY  J V? 

)|c5X'l)  RE-ENTER  THE\  SLOPE  VALUE'/? 

)fc5X'2)  START  OVER'/? 

)Ji5X“3)  EXIT  FROM  THIS  ROUTINE'/? 

3^:5X'ENTER  YOUR  CHOICE  HERE  ->  _*) 

113  F0RMAT(/?5X' SELECT  ONE  OF  THE  FOLLOWING  OPTIONS  t'/? 

)K5X'l)  LET  ME  USE  MY  OWN  VALUE'/? 

5*^5X“2)  GIVE  ME  A SUGGESTION  THAT  WILL  ENABLE'/? 

)(^5X'  ME  TO  USE  THE  VALUE'/? 

*5X'3)  GET  ME  OUT  OF  HERE'/? 

*5X'ENTER  YOUR  CHOICE  HERE  ->  ^') 

121  F0RMAT(/?5X'ERR0R  ->  THE  CURRENT  MINIMUM  SLOPE  REQUEST  FOR'/? 

)F-5X' HIGHWALL  *12“  IS  'F5.2'  DEGREES.  YOU  CAN  :'/? 

)K5X‘l)  RE-ENTER  YOUR  VALUE"/? 

>I^5X‘2)  START  OVER"/? 

3fc5X'3)  OBTAIN  A SUGGESTION  THAT  WILL  LET  YOU  USE  THIS  SLOPE'/? 
)Jc5X'4)  EXIT  FROM  THIS  ROUTINE'/? 

){«5X' ENTER  YOUR  CHOICE  HERE  ->  _') 
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428  kof;:mat(/t5x-suggestion  :v/j 

)f:5X*lF  YOU  INCREASE  ECNCH  'I2'  FROM  'F7*2''  FEET  » TOV/y 
)J:5XF7»2'  FEETy  THE  FINAL  SLOPE  VALUE  OF  -F5*2-  DEGREES *//y 
)f:5X"WILL  WORK*  “) 

478  F0RMAT(/y5X"SUGGESTI0N  :"//y 

YOU  INCREASE  DENCH  ‘■I2*  FROM  •F7*2"  FEEfy  TOV/y 
3tc5XF7*2'  FEEfy  AND  INCREASE  DENCH  *12’  FROM  "F7*2*  FEETy  TOV/ 
<c5XyF7*2'  FEEfy  WE  CAN  USE  THE  SLOPE  VALUE  FOR  HIGHWALL  "I2y// 
481  FORMAT  <//y5X"  YOU  CAN  :V/y 

IMPLEMENT  THE  ABOVE  SUGGESTION •// y 
USE  YOUR  OWN  DENCH  ADJUSTMENTS V/y 
*5X-3)  INPUT  A DIFFERENT  SLOPE  VALUE V/y 

t5X^A)  RE-INPUT  ALL  FINAL  SLOPES  FOR  THIS  ALTERNATIVE “// y 
3f:5X“5>  EXIT  FROM  THIS  OPTIONV/y 
)|C5X*ENTER  YOUR  CHOICE  HERE  ->  _*) 

511  FORMAT </y5X' INPUT  DENCH  -12" 'S  NEW  VALUE  ->  _-) 

END 

END$ 
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STSIHB  T=00004  IS  ON  CR00015  USING  00039  BLKS  R=0000 


0001  FTN4 

0002  SUBROUTINE  TSIHB 

0003  C TRUCK  AND  SHOVEL  J INPUT  HIGHUALL  / BENCH  INFORMATION 

0004  C 

0005  C LEVEL  3 

0006  C 

0007  C THE  INITIAL  HIGHWALL  AND  BENCH  DESCRIPTION  FOR  THE  CURRENT 

0008  C LAND  USE  OPTION  IS  ENTERED*  IMMEDIATE  INSPECTION  AND  EDIT 

0009  C OF  THE  INPUT  DATA  IS  OFFERED*  BENCH  LENGTHS  ARE  TESTED 

0010  C FOR  VALIDITY  AND  ADJUSTED  IF  REQUIRED* 

0011  C 

0012  C TSIHB  IS  ACCESSED  BY  TSGE  AND  SWAPPED  IN  BY  PROGRAM  TSIHX 

0013  C 

0014  C THE  CALLING  SEQUENCE  IS  : CALL  TSIHB 

0015  C 

0016  C 

0017  C TSIHB  CALLS  THE  SUBROUTINES  : 

0018  C ERASE  (TCS) 

0019  C HOME  (TCS) 

0020  C TSBLA  (CLAIM) 

0021  C 


0022  C THE  LOCAL  VARIABLES  ARE  : 

0023  C 

0024  C IPTR  “>  EDIT  POINTER 

0025  C 

0026  C THIS  R0U7INE  WAS  WRITTEN  BY  GREEN 

0027  C 


0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 

0048 

0049 

0050 

0051 

0052 

0053 

0054 


C CLAIM  RELEASE  1*0  - APRIL  1»  1980 

C 

c 

C TEKTRONIX  COMMON 

C 

COMMON  ITEK  (45) 

C 

C LOGICAL  UNITS  AND  COMMON  LOCATION 

C 

COMMON  IARRY(5) y IARY2(5) ?LERyLUF,LUL 
C 

C POINTERS 

C 

COMMON  EXIT  y IANM(3) ? ICLI (2) » IGEN(3) y 1GRW(5) 

COMMON  lOPTN  yI0VR(7)yIHB  y ISOC ( 6 ) y ISUB ( 8 ) 

COMMON  1SUR(6) y IT0P(9) y IVEG(2) yLEXIT  yLUO 
COMMON  MODE  yNANM  yNCLI  yNGEN  yNGRW 

COMMON  NOVR  yNSECTS  yNSOC  yNSUB  yNSUR 

COMMON  NTOP  yNU  yNVEG 

C 

C GRADING  PARAMETERS 

C 

COMMON  AREA ( 5 ) y BENLEN ( 5 y 1 0 ) y BENWI ( 5 y 1 0 ) y C060  y 6CPA ( 5 ) 
COMMON  SPCC(5)  yHWHT  (5y  10)  yl-IWSLKSy  10)  yNHBP(5)  yPCEQ19(4) 
COMMON  BEMWF(5y  10)  yREHCPY(5)  yREHV0L(5)  yHWSLF-  (5y  10)  yUSR 
C 
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0055  C CATEGORY  TEXT 


0056 

0057 

0058 

0059 

0060 
0061 
0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 
OOBl 
0082 

0083 

0084 

0085 

0086 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 
0101 
0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


C 


C 

C 

C 


C 

C 

C 


C 

C 

C 


C 


c 


c 

c 

c 

c 

c 


c; 


COMMON  ANIM(23t13) yCLMA(13>13) »6HES(15t13) jGWHY(22^ 13) 
COMMON  0'v'BD(llrl3)»SBSL(13)>  SCEC  ( 33 » 13 ) f SWHY  ( 44  y 13 ) 
COMMON  TPSL(49yl3)»06TA(15yl3) 

EXPECTATION  OALUES 

COMMON  ANIMAL(13»6) jCLIMAT(8y6) »GENLiES(8y6) yGRWHYD(19, 
COMMON  OORBDN ( 28  y 6 ) > SOCECN ( 29  y 6 ) y SUBSO 1 < 30  y 6 ) y SURH YD ( 2 
COMMON  TOPSO I ( 33  y 6 ) y OEGETA ( 1 0 y 6 ) 

CATEGORY  RESPONSES 

COMMON  RANIMA<3) yRCLIMA(2) yRGENDE<3) yRGRWHY(5) 

COMMON  R00RBD(7y 10) yRS0CEC<6) yRSUES0(8) yRSURHY(6) 
COMMON  RT0PS0(9) yRVEGET(2) 

PEASIyTECONyOPUSE  SUBSYSTEM  PARAMETERS 


COMMON  CAAHM  y CABAH  y CABPN ( 3 ) y CABFP  < 3 ) y CABHM 

COMMON  CABS ( 2 ) y C AC  y CACP  y CADE  y CADH 

COMMON  CADS  y CAEAF  y CAHSAP  y CAHSTS  y CA I P 

COMMON  CAR3FCyCASFyCASNCyCSTESyCSTRM 

COMMON  CSTRP  y FAOG ( 5 ) y PFSTSP  y PF AC  y RCLTEC ( 29  y 34 ) 

COMMON  TCAR(5) yTHICKC 10) y THKTS y TTL ( 40 ) 

INTEGER  EXI T y CLMA  y GDES  y GWHY  y OVBD  y SBSL 
INTEGER  SCECySWHYyTPSLyOGTAyANIM 
INTEGER  CLIMATy GENDESy GRWHYDyOORBDN 
INTEGER  SOCECN ySUBSOIySURHYDyTOPSOI 
INTEGER  OEGETAy ANIMAL 

1 NTEGER  RCL I MA  y RGENDE  y RGRWHY  y ROORBD  y RSOCEC 
INTEGER  RSUBSO y RSURHY  y RTOPSO  y RVEGET  y RANIMA 
INTEGER  RCLTEC y TTL 

INTEGER  COMMON  (1) 

EQUIVALENCE  (COMMON  (l)y  ITEK  (1)) 

EQUIVALENCE  (lARRY  (l)y  LUT) 

EQUIVALENCE  (1ARY2  (l)y  ISTRK) 

EQUIVALENCE  (IARY2  (2)y  ISECT) 

EQUIVALENCE  (IARY2  (3)y  ICODE) 

EQUIVALENCE  (IARY2  (4)y  LEN) 

LOGICAL  LER 

IF(I0PTN*EQ*2)  GOTO  605 


DISPLAY  INSTRUCTIONS  AND  INITIATE  LOOP 

50  IHB  = 0 

URI'IECLUTy  1050) 

60  IHB  = IHB  -f  1 

IF<1HB*GIM0)  GOTO  600 
WRITE(LU  f y 1060)  IHB 
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0111 

0112 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120 

0121 

0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

015/ 

0158 

0159 

0160 

0161 

0162 

0163 

0164 

0165 

0166 


C 

C 

100 


C 


C 

C 

C 


C 


C 

C 

C 


300 


0 


c 

c 

c 

400 


C 


405 


C 

C 

C 


C 

C 

C 


500 


600 

605 


610 


INPUT  THE  HIGHWALL  HEIGHT  (ZERO  MEANS  QUIT) 

WRITECLUTy 1100) 

READ(LUTj:^c)  HUHT(LU0>  IHB) 

IF(HWHT(LUOj IHB) ♦EQ.O)  GOTO  600 
1F*<HWHT(LU0tIHI-{)  *GT*0)  GOTO  200 

WRITECLUTy 1150) 

GOTO  100 

INPUT  THE  BENCH  WIDTH 

WRITE(LUTy 1200) 

READ  ( LUT  y )^ ) BENWI  ( LUO  y I HB ) 

IF(BENWI (LUOy IHB) ♦GT*0)  GOTO  300 

WRITE (LUI y 1150) 

GOTO  200 

INPUT  IHE  INITIAL  HIGHWALL  SLOPE 

WRITE (LUTy 1300) 

REAIKLUTy^f:)  HWSLI  < LUO y IHB ) 

IF(HWSLI (LUOy IHB) ♦GT^O* ♦ AND ♦ HWSLI ( LUO y IHB ) 
T»LT*90* ) GOTO  400 

WRITECLUT  y 1350) 

GOTO  300 

INPUT  THE  BENCH  LENGTH 

WRITE (LUT  y 1400) 

READ(LUTy)fO  BENLEN ( LUO y IHB ) 
lF(BENLEN(LUOy IHB) *LE*0» ) GOTO  405 
IF(1HB*EQ»1)  GOTO  500 

IF(DENLEN(LUOy IHB) ♦LE»BENLEN(LUOy lHB-1) ) GOTO  500 

WRITE(LUTy4012)  BENLEN ( LUO y IHB-1 ) 

GOTO  400 
WRlTECLUTy 1150) 

GOTO  400 

GET  THE  NEXT  PAIR 


IF(LER)  CALL  ERASE 
IF(LER)  CALL  HOME 
GOTO  60 

SET  NHBPy  THEN  DISPLAY  THE  CURRENT  DATA 

NHBP(LUO)  = IHB  - 1 
1F(NHBP(LU0) ♦EQ*0)  RETURN 
WRITE(LUTy4010) 

READ  < LUT  y)^0  SPCC(LUG) 

IF(SPCC(LU0) ♦LI ♦ 1 V *OR*SPCCCLUO) *GT *2. ) GOTO  605 
IF(LER)  CALL  ERASE 


322 


0167 

0168 

0169 

0170 

0171 

0172 

0173 

0174 

0175 

0176 

0177 

0178 

0179 

0180 

0181 

0182 

0183 

0184 

0185 

0186 

0187 

0188 

0189 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

0197 

0198 

0199 

0200 

0201 

0202 

0203 

0204 

0205 

0206 

0207 

0208 

0209 

0210 

0211 

0212 

0213 

0214 

0215 

0216 

0217 

0218 

0219 

0220 

0221 

0222 


IF(LER)  CALL  HOME 


C 

C 

C 


C 

C 

C 


C 


C 


UFaTE(LUTj2000) 

DO  650  1 = ItNHBP(LUO) 

650  WRITE(LUT»2010)  I y HWHT< LUO j I ) y HWSLI ( LUO y I ) y 
> DENWKLUOyl)  yBEMLEM(LUOyl) 

GET  THE  H/D  NUMBER  OF  EDIT<ZERO  MEANS  QUIT) 

670  URITECLUI y2020) 

READ(LUTy)Jc)  IHB 
IF<IHB*EQ*0)  GOTO  3000 

IF(IHB*GE*1»AND*IHB»LE*NHBP<LU0)  + 1)  GOTO  700 
URITECLUTy 1010)  IHB 
GOTO  670 

GET  ITEM  TO  BE  EDITED  - TEST  FOR  ADDITIONAL  H/B  PAIR 

700  IF(IHB.NE»NHBP(LUO)  + 1)  GOTO  710 
IHB  = NHBP(LUO) 

GOTO  500 

710  WRITE(LUTy2030) 

READCLUT  y)«c)  IPTR 
1F(IPTR*EQ*0)  GOTO  610 
I F ( I PTR ♦ 6E ♦ 1 ♦ AND . I PTR ♦ LE ♦ 4 ) 

>G0T0(800y 900 y 1000 y 1040)  IPTR 
WRITECLUfy 1010) 

GOTO  710 


C EDIT  THE  HIGHUALL  HEIGHT 

C 


C 

C 

C 


C 


BOO  WRITE<LUTy 1100) 

READ(LUTy)fc)  HUHT  < LUO  y IHB ) 
lF<HWHT(LUOy IHB) *GT*0* ) 610y  800 

EDIT  THE  BENCH  WIDTH 

900  WRITECLUT y 1200) 

READ(LUTy)^0  BENWI  < LUO y IHB ) 
IF(BENWKLUOylHB)  .6T*0*  ) 610y900 


C EDIT  THE  INITIAL  HIGHUALL  SLOPE 

C 

1000  WRITE(LUTy 1300) 

READ<LUTy  3^c)  HWSLI  ( LUO y IHB ) 

IFCHUSLI (LUOy IHB) ♦GT.O* ♦ AND ♦ HWSLI ( LUO y IHB ) .LT  *90* ) 

> 6i0y  1000 


C 


C EDIT  THE  BENCH  LENGTH 

C 


1040  URITECLUT y 1400) 

READ ( LUT  y t ) BENLEN  < LUO  y I HB ) 

■lF<IHB»EQ*l*AND*BENLEN(LUOyl) ♦ GE ♦ BENLEN ( LUO y 2 ) ) GOTO  610 
IF< IHB*GT* 1 .AND, IHB*LT»NHBP(LUO) 

>,AND,BENLEN(LUOy IHB) ,LE,BENLEN<LUOy IHB-1 ) 

>,  AND,  BENLEN  < LUOy  I HB)*6E,  BENLEN  ( LUO  ylHB+D)  GOTO  610 
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0223 

0224 

0225 

0226 

0227 

0228 

0229 

0230 

0231 

0232 

0233 

0234 

0235 

0236 

0237 

0238 

0239 

0240 

0241 

0242 

0243 

0244 

0245 

0246 

0247 

0248 

0249 

0250 

0251 

0252 

0253 

0254 

0255 

0256 

0257 

0258 

0259 

0260 
0261 
0262 

0263 

0264 

0265 

0266 

0267 

0268 

0269 

0270 

0271 

0272 

0273 

0274 

0275 

0276 

0277 

0278 


IFdHB.EQ^NHBPCLUO)  . ANruBENLEN(LUOdHB)  ♦LE.BENLEN<LUO,  IHB 
>60T0  610 

IF<IHB»EQ*1)  GOTO  1041 
IF(IHB»EQ»NHBP(LUO) ) GOTO  1042 

WRITE<LUTr4011 ) BENLEN < LUO y IHB+1 ) » BENLEN ( LUO dHB-1 ) 

GOTO  1040 

1041  WRITE(LUTr4013)  BENLEN < LUO ? 2 ) 

GOTO  1040 

1042  WRI TE(LUT j4012)  BENLEN ( LUO y IHB-1 ) 

GOTO  1040 

C 

C CHECK  SEMI-CIRCULAR  SPOILS  FOR  EXCESSIVE  BENCH  LENGTHS 

C 

3000  IF(SPCC*EQ.2* ) RETURN 
IPTR  = 3 

CALL  TSBL A < I PTR  y I CHB  y PARAM 1 y PARAM2 ) 
IF(IPTR*EQ*0*ANLU10PTN*EQ.1)  GOTO  610 
RETURN 
C 

C FORMAT  STATEMENTS 

C 

1010  F0RMAT(2Xy 12*  ??  ERROR  ->  RE-INPUT.') 

1050  F0RMAT(/y5X' INPUT  UALL/BENCH  INFORMATION  :'//y 
+5X'>  BEGIN  WITH  BOTTOM  HIGHWALL  ANB  BENCH'/y 
+5X"  PROCEEDING  UPWARD  UNTIL  DONE'//y 
+5X">  WHEN  DONE y ENTER  ZERO  FOR  THE  HEIGHT '/y 
+5X'  OF  WHAl  WOULD  HAVE  BEEN  THE  NEXT  HIGHWALLV/y 
+5X">  10  HIGHWALL//BENCH  PAIRS  ARE  ALLOWED'// 

+5X'>  WIDTH  OF  TOP  BENCH  CAN  BE  NO  GREATER'/ 

-F5X'  THAN  ONE  HALF  THE  WIDTH  OF  THE  HILL  TOP'//) 

C 

1060  F0RMAT(/y5X'N0W  DESCRIBING  HIGHWALL/BENCH  PAIR  t'12y/) 

C 

1100  FORMAT(  5X' VERTICAL  HEIGHT  OF  HIGHWALL (FEET ) ->  _') 

C 

1150  F0RMAT(/y5X'ERR0R  ->  VALUE  MUST  BE  GREATER  THAN  ZERO.'/) 

C 

1200  F0RMAT(5X'WIDTH  OF  THE  BENCH<FEEf)  ~>  _') 

C 

1300  F0RMAT(5X' INITIAL  SLOPE  OF  THE  HIGHWALL ( DEGREES ) ->  «') 

C 

1350  F0RMAT(5X'ERR0R->  SLOPE  MUST  BE  BETWEEN  0 AND  90  DEG.') 

C 

1400  F0RMAT(5X'LENGTH  OF  BENCH  ALONG  OUTSIDE  EDGE(FEET)  ->  _') 
C 

2000  FORMAT <15X')t:)if:(f  CURRENT  HIGHWALL/BENCH  DATA 

>2X'PAIR  HW  HEIGHT  HW  SLOPE  BENCH  WIDTH  BENCH  LENGTH 

C 

20 1 0 FORMAT ( 2X  y 1 2 y 4X  y F9 . 2 y 2X  y F8 ♦ 2 y 2X  y F 1 1 ♦ 2 y 2X  y F 1 3 * 2 ) 

C 

2020  F0RMAT(/2X'HIGHWALL/BENCH  PAIR  NUMBER  OF  EDIT(0  TO  QUIT)  ■ 
C 

2030  FORMAT </2X' ITEM  TO  BE  EDITED  ?'/ 

> 2X'0  ->  DONE'/ 

> 2X'l  ~>  HIGHWALL  HEIGHT '/y 


1)  ) 


/ 

/) 


>-'  ) 
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0279 

0280 
0281 
0282 

0283  C 

0284  4010  KORhAT (/SX* INPUT  SPOIL  PILE  CONFIGURATION  CODE  :"/ 

0285  > 5X'l->  SEMI-CIRCULAR  SPOILS'/^ 

0286  > 5X*2->  RECTANGULAR  SPOILSV» 

0287  P > 5X-ENTER  CONFIGURATION  BEST  DESCRIBING  SPOILS  ->  «■) 

0288  C 

0289  4011  FORMAT (/5X" ERROR*  BENCH  LENGTH  MUST  BE  GREATER  THAN  OR"/ 

0290  > 5X"EQUAL  TO'FIO.2"  FEET>  AND  LESS  THAN  OR  EQUAL' 

0291  >/  5X"T0"F10*2"  FEET*  TRY  AGAIN*') 

0292  C ' 

0293  4012  F0RMAT(/5X'ERR0R*  BENCH  LENGTH  MUST  BE  LESS  THAN  OR  EQUAL'/ 

0294  > 5X'T0'F10*2'  FEET*  TRY  AGAIN*') 

0295  C 

0296  4013  F0RMAT(/5X"ERR0R*  BENCH  LENGTH  MUST  BE  GREATER  THAN  OR'/ 

0297  > 5X' EQUAL  T0'F10*2'  FEET*  TRY  AGAIN*') 

0298  C 

0299  C 

0300  END 

0301  END$ 


2X'2  ->  BENCH  WIDTH'/? 

2X'3  ->  HIGHUALL  SLOPE"/? 

2X'4  ->  BENCH  LENGTH'/? 
2X'ENTER  YOUR  SELECTION  ->  «') 
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0020 
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T=00004  IS  ON  CR00015  USING  00010  BLKS  R=0000 


FTN4 

SUBROUT I NE  TSRC  < LUO » NUMBR » HUSL I » HUNT , HUSLF  f BENWF  r BENWI ) 

C —-TRUCK  AND  SHOVEL  RECALCULATIONS 

C 

C LEVEL  4 
C 

C THIS  ROUTINE  RECALCULATES  FINAL  BENCHES  WHEN  THE  USER 

C INITIATES  A ‘MID-STREAM'  CHANGE  IN  BENCH  WIDTH* 

C 

C TSRC  IS  ACCESSED  BY  TSIFN 
C 

C THE  CALLING  SEQUENCE  IS  : 

C 

C CALL  TSRC  (LUO,NUMBR>HWSLI y HWHTrHWSLFjBENWFr BENWI ) 

C 


C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


c 

c 

c 

c 

c 

c 

c 

c 


WHERE  : 

LUO  “>  LAND  USE  OPTION 

NUMBR  ->  CURRENT  HIGHWALL  / BENCH  PAIR 
HWSLI  ->  INITIAL  HIGHWALL  SLOPES 
HWHT  ->  HIGHWALL  HEIGHTS 
HWSLF  ->  FINAL  HIGHWALL  SLOPES 
BENWF  ->  FINAL  BENCH  WIDTHS 
BENWI  ->  INITIAL  BENCH  WIDTHS 

SUBROUTINES  SCHEDULED? 

TSDBR  (CLAIM) 

LOCAL  variables: 

BENR  ->  BENCH  REMOVED 
THIS  ROUTINE  WAS  WRITTEN  BY  GREEN 

CLAIM  RELEASE  1*0  - APRIL  1»  1980 


DIMENSION  HWSLI (5» 10) » HWHT ( 5 » 10 ) j HWSLF < 5 y 10 ) » BENWF ( 5 y 10 ) » 
t BENWK5ylO) 

IF  WE'RE  AT  NUMBR  = ly  WE'RE  DONE 

IF  (NUMBR  *EQ*  1)  RETURN 

START  RECALCULATING*  WE  DON'T  HAVE  TO  CHECK  SLOPES 

HEREy  BECAUSE  AN  INCREASE  IN  ANY  BENCH  WIDTH  WILL 

NOT  AFFECT  RESTRICTIONS  TO  A PREVIOUS  LEGAL  SLOPE  REQUEST 

DO  2 JJ  =••  ly  10 

2 BENWF  (LUOy  JJ)  = BENWI  (LUOy  JJ) 

3 J = 1 

5 CALL  TSDBR  (HWHT  ( LUO y J ) y HWSLI  ( LUO y J ) y HWSLF  ( LUO y J ) y BENR ) 
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0055 

IF  (J  ♦EQ* 

0056 

BENWF  (LUOy 

0057 

10 

BENWF  (LUOy 

0058 

J = J + 1 

0059 

IF  (J  *LT* 

0060 

RETURN 

0061 

0062 

END$ 

END 

1)  GOTO  10 
J-1)  = BENWK  (LUOy 
J)  = BENWF  (LUOy  J) 

NUMBR)  GOTO  5 


I 


i 


{ 


-1)  - BENR 
- BENR 
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&TSRIE  1=00004  IS  ON  CR00015  USING  00020  BLKS  R=0000 
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0023 

0024 

0025 

0026 

0027 

0028 
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0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 
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0040 
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FTN4 

C TRUCK  AND 

C 

C LEKfEL  3 
C 


SUBROUTINE  TSRIE 

SHOVEL  REHANDLE  INPUT  AND  EDIT 


C TSRIE  IS  ACCESSED  BY  TBGE 
C 

C THE  CALLING  SEQUENCE  IS  : CALL  TSRIE 
C 

C THE  LOCAL  VARIABLES  ARE  : 

C 

C ICHNG  ->  EDIT  POINTER 

C 


C THIS  ROUTINE  WAS  WRITTEN  BY  GREEN/EASTMAN 


C 


c CLAIM  RELEASE  1.0  - APRIL  If  1980 

C 


C 

C TEKTRONIX  COMMON 

C 

COMMON  ITEK  (45) 

C 

C LOGICAL  UNITS  AND  COMMON  LOCATION 

C 

COMMON  IARRY(5) y 1ARY2<5) tLERtLUF  »LUL 
C 

C POINTERS 

C 

COMMON  EXIT  y I ANM ( 3 ) y ICL 1 < 2 ) y I GEN < 3 ) y I GRW ( 5 ) 

COMMON  lOPTN  yI0VR(7)ylHB  y ISOC ( 6 ) y I SUB < 8 ) 

COMMON  ISUR(6)yIT0P<9)yIVEG(2)yLEXIT  yLUO 
COMMON  MODE  yNANM  yNCLI  yNGEN  yNGRW 

COMMON  NOVR  yNSECTS  yNSOC  yNSUB  yNSUR 

COMMON  NIOP  yNU  yNVEG 

C 

C GRADING  PARAMETERS 

C 

COMMON  AREA(5) y BENLEN(5y 10) yBENWI (5y 10) yC0G0yGCPA<5) 

COMMON  SPCC<5) yHWHT(5y 10) yHWSLKSy 10) yNHBP<5) y PCEQ19(4) 
COMMON  BENWF(5y 10) yREHCPY<5) y REHVOL ( 5 ) y HWSLF ( 5 y 1 0 ) yUSR 
C 

C CATEGORY  TEXT 

C 

COMMON  ANIM(23y 13) y CLMA( 13y 13) yGDESX 15y 13) y GWHY<22y 13) 
COMMON  0VBD(llyl3)ySBSL(13)y  SCEC(33yl3)ySWHY(44yl3) 

COMMON  TPSL(49y 13) y VGTA< 15y 13) 

C 

C EXPECTATION  VALUES 

C 

COMMON  AN I MAL ( 1 3 y 6 ) y CL I MAT ( 8 y 6 ) y GENDES ( 8 y 6 ) y GRWH YD  < 1 9 y 6 ) 
COMMON  0VRBDN(2By6) y SOCECN < 29 y 6 ) y SUBSO I ( 30 y 6 ) y SURHYD < 23 y 6 ) 
COMMON  TOPSO I < 33  y 6 ) y VEGETA ( 10  y 6 ) 


'IF' 
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ro  sj  cn 


C 

C 

c 


c 

c 

c 


c 


c 


c 


c 

c 


c 

c 

c 


c 

c 


CATEGORY  RESPONSES 

COMMON  RANIMA<3) tRCLIMA(2) jR6ENDE<3) yRGRWHY(5) 
COMMON  R00RB1K7» 10) > RSOCEC ( 6 ) > RSUBSO ( 8 ) > RSURHY ( 6 ) 
COMMON  RT0PS0(9) »R0EGET<2) 

feasitTECONjOPUse  subsystem  parameters 

COMMON  CA AHM > CABAH  j C ABFN ( 3 ) » CABFP (3) f CABHM 

COMMON  CABS (2)7  CAC  7 C ACP  7 CABF  7 CADH 

COMMON  CADS  7 CAEAF  7 CAHSAF  7 CAHSTS  7 CAIP 

COMMON  CAR3FC  7 CASF  7 CASNC  7 CSTES  7 CSTRM 

COMMON  CSTRP  7 F AOG ( 5 ) 7 PFSTSP  7 PF AC  7 RCLTEC ( 29  7 34 ) 

COMMON  TCAR(5) 7THICK(10) 7THKTS7TTL(40) 

1 NTEGER  EX I T 7 CLMA  7 GDES  7 GWH Y 7 0 VBD  7 SBSL 
INTEGER  SCEC7SWHY7TPSL7OGTA7ANIM 
INTEGER  CLIMAT7GENDES7GRUHYD7OORBDN 
INTEGER  SOCECN7SUBSOI 7SURHYD7TOPSOI 
INTEGER  VEGETA  7 ANIMAL 

INTEGER  RCL I MA  7 RGENDE  7 RGRUHY  7 ROVRBD  7 RSOCEC 
INTEGER  RSUBSO  7 RSURHY  7 RTOPSO  7 RVEGET  7 RANIMA 
INTEGER  RCLTEC 7 TTL 

INTEGER  COMMON  (1) 


EQUIVALENCE 

(COMMON 

(1) 

7 ITEK  (1)) 

EQUIVALENCE 

(lARRY 

(1)7 

LUT) 

EQUIVALENCE 

(IARY2 

(1)7 

ISTRK) 

EQUIVALENCE 

(IARY2 

(2)7 

ISECT) 

EQUIVALENCE 

(1ARY2 

(3)7 

I CODE) 

EQUIVALENCE 

(IARY2 

(4)7 

LEN) 

LOGICAL  LER 


COMMON  /ALTRN/  ALTN 
INTEGER  ALTN  (674) 

DISPLAY  CURRENT  DATA  C IF  EDIT  MODE  3 

IF  (MODE  *EQ*  4)  GOTO  5 

IF  (LER)  CALL  ERASE 

IF  (LER)  CALL  HOME 

WRITE  (LUT7  1000)  (ALTN  (LUO7  8)7  J = I7  4) 

IF  (lOPTN  .NE*  1)  77  40 

WRITE  (LUT7  10)  REHVOL  (LUO) 7 REHCPY  (LUO) 
WRITE(LUT7  14) 

READ  (LUT7  t)  ICHNG 
IF  (ICHNG  .EQ4  0)  RETURN 

IF  (ICHNG  .GE*  I^AND^ICHNG  ^LE*  2)  17 r 15 
15  WRITE  (LUT7  16)  ICHNG 
GOTO  5 

17  GOTO  (407  45)  ICHNG 

INPUT  REHANDLE  INFORMATION 
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C 

40  WRITE  <LUT>  41) 

READ  (LUr»  REHOOL  (LUO) 

IK  (lOPTN  .EQ*  1)  45»  5 

45  WRITE  (LUTj  46) 

READ  <LUT»  t)  REHCPY  (LUO) 

IK  (lOPTN  1)  RETURN 

GOTO  5 
C 

C FORMAT  STATEMENTS 

C 

10  F0RMAT(/>5X*REHANDLE  INFORMATION 

)tc5X‘l  ->  REHANDLE  OOLUME  IS  ->-F10*l*  CUBIC  YARDSV» 

tSX‘2  ->  REHANDLE  COST  IS  ~>'F10*1"  CENTS/CU*  YD*“)  , 

C 

14  FORMAf (/>5X'ENTER  THE  ITEM  YOU  WISH  TO  CHANGE  (0  TO  QUIT)  ->  ^‘) 
C 

16  F0RMAT(/,5X» 12"  ? ERROR  ~>  ILLEGAL  ENTRY*  RE-SELECT V ) 

C 

41  FORMAT (/>5X" TOTAL  VOLUME  OF  REHANDLE  (CU*YDS)  ->  «*) 

C 

46  FORMAT (/j5X" COST  OF  REHANDLE  ( CENTS/CU ♦ YD ♦ ) ->  ) 

C 

1000  FORMAT (/5X"*)f(  TRUCK  AND  SHOVEL  SEGMENT  - "4A2"  ALTERNATIVE  tt- ) 
END 

END$ 
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FTN4 

SUBROUTINE  TSSCI 

C TRUCK  AND  SHOVEL  : SELECTIVE  CHANGES  TO  INITIAL  DATA 

C 

C LEVEL  3 
C 

C THIS  ROUTINE  SCHEDULES  SELECTIVE  CHANGES  TO  INITIAL  HIGHUALL 

C AND  BENCH  DATA* 

C 

C TSSCI  IS  ACCESSED  BY  TSGE  AND  SWAPPED  IN  BY  PROGRAM  TSSCX 
C 

C THE  CALLING  SEQUENCE  IS  : CALL  TSSCI 

C 

C SUBROUTINES  SCHEDULED! 

C 

C ERASE  (TCS) 

C HOME  <TCS) 

C 7SDBR  (CLAIM) 

C TSBLA  (CLAIM) 

C 

c LOCAL  variables: 

C 

C BENCH  ->  USER  INPUT  BENCH  WIDTH 

C BRNEW  ->  BENCH  REMOVED  BY  NEW  INITIAL  SLOPE 

C BROLD  ~>  BENCH  REMOVED  BY  THE  OLD  INITIAL  SLOPE 

C HEIGHT  ->  USER  INPUT  HIGHWALL  HEIGHT 

C IHBB  ->  NUMBER  OF  HIGHWALL/BENCH  BELOW  CURRENT  PAIR 

C SLI  ~>  USER  INPUT  INITIAL  SLOPE 

C 

C THIS  ROUTINE  WAS  WRITTEN  BY  EASTMAN  / GREEN 
C 

C CLAIM  RELEASE  1*0  - APRIL  If  1980 

C ===  = ===:====  = =:===:  = ====r===r=:=:  = ====  = r:===:==============  = ===:=======:====  = ======  = = =======:===:========  = ==========^ 

c 

C TEKTRONIX  COMMON 

C 

COMMON  ITEK  (45) 

C 

C LOGICAL  UNITS  AND  COMMON  LOCATION 

C 

COMMON  IARRY(5) » IARY2( 5 ) y LER j LUF » LUL 
C 

C POINTERS 

C 

COMMON  EXIT  y IANM(3) » ICLI (2) ? 1GEN(3) » IGRW(5) 

COMMON  lOPTN  yI0VR(7)ylHB  y ISOC ( 6 ) y ISUB ( 8 ) 

COMMON  ISUR(6) y IT0P(9) y IVEG(2) yLEXIT  yLUO 
COMMON  MODE  yNANM  yNCLl  yNGEN  yNGRW 

COMMON  NOVR  yNSECTS  yNSOC  yNSUB  yNSUR 

COMMON  NTOP  yNU  yNVEG 

C 

C GRADING  PARAMETERS 

C 

COMMON  AREA ( 5 ) y BENLEN ( 5 y 1 0 ) y BENWI ( 5 y 1 0 ) y COGO  y GCPA ( 5 ) 

« 
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0101 
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C 

C 

C 


C 

C 

C 


C 

C 

C 


C 

C 

c 


c 


c 


c 

c 

c 

c 

10 

100 

101 


COHMON  SPCC(5) yHWHr  <5» 10) »HWSLl(5ylO) >NHBP(5) jPCEQ19(4) 
COMMON  BENWF (5»10) »PEHCPY(5) ,PEH00L(5) >HWSLF(5>10) rUSR 

CATEGORY  TEXT 

COMMON  ANIM(23»13) jCLMA(13»13) >6DES(15>13) tGWHY(22t13) 
COMMON  00BD(11,13)tSBSL<13),  SCEC ( 33 > 13 ) j SWHY < 44 t 13 ) 
COMMON  TPSL(49y 13) >0GTA(15j13) 

EXPECTATION  VALUES 

COMMON  ANIMAL(13y6) >CLIMAT(8y6) >GENBES<8j6) jGRUHYB(19f 
COMMON  0VRBBN(28j6) j SOCECN ( 29 > 6) j SUBSOl <30»6) > SURHYB(2 
COMMON  TOPSOI <33j6) y VEGETA<10j6) 

CATEGORY  RESPONSES 

COMMON  RANIMA(3) > RCLIMA < 2 ) » RGENBE ( 3 ) y RGRWHY ( 5 ) 

COMMON  R0VRBD(7»10) »RS0CEC(6) rRSUBS0<8) jRSLlRHY(6) 

COMMON  RT0PS0(9) tRVEGET<2) 


FEASI »TECON>OPUSE  SUBSYSTEM  PARAMETERS 


COMMON  CAAHM  r CABAH  ? CABFN  < 3 ) ? CABFP ( 3 ) » CABHM 

COMMON  CABS ( 2 ) > C AC  f CACP  > CADF  > CABH 

COMMON  CADS » CAEAF  ? CAHSAF » CAHSTS , CAIP 

COMMON  CAR3FC  y CASF  ^ CASNC  ? CSTES  > CSTRM 

COMMON  CSTRP , FA VG ( 5 ) » PFSTSP f PFAC y RCLTEC ( 29 » 34 ) 

COMMON  TCAR(5) »THICK(10) » I HKTS » TTL < 40 ) 


I NTEGER  EX I T j CLMA  T GBES » GWHY  ? OVBB  > SBSL 
INTEGER  SCEC  y SWHY  y TPSL  y VGTA  y ANIM 
INTEGER  CLIMATyGENDESyGRlvlHYDyOVRBDN 
INTEGER  SOCECNy SUBSOI ySURHYDy TOPSOI 
INTEGER  VEGETA y ANIMAL 

1 NTEGER  RCL I MA  y R6ENDE  y RGRWHY  y ROVRBB  y RSOCEC 
INTEGER  RSUBSO  y RSURH Y y RTOPSO  y RVEGET  y RANIMA 


INTEGER  RCLTEC yTTL 


INTEGER  COMMON  (1) 


EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 


(COMMON  (l)y 
(lARRY  (l)y 
(IARY2  <l)y 
(IARY2  (2)y 
(1ARY2  (3)y 
(1ARY2  <4)y 


ITEK  (1)) 
LUT) 

ISTRK) 

ISECT) 

I CODE) 

LEN) 


LOGICAL  LER 


GET  H/B  NUMBER  OF  EDIT 


IF  (LER)  CALL  ERASE 
WRITE  (LUTy  111)  NHBP  (LUO) 

READ  (LUTy  t>  IHB 

IF  (IHB  ,EQ«  0)  RETURN 

IF  (IHB  .GT*  0 *AND^  IHB  ♦LE*  NHBP  (LUO))  GOTO  150 
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0123 
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C 

WRITE'  (LUTf  112)  IHB 
GOTO  101 
C 

C GET  EDIT  ITEM 

C 

150  IF  (LER)  CALL  ERASE 
IF  (LER)  CALL  HOME 
WRITE  (LUTy  151)  IHB 
152  READ  (LUTy  ICODE 

IF  (ICODE  ♦EQ*  0)  GOTO  10 

IF  (ICODE  *GE*  1 *ANDi  ICODE  ♦LE*  4)  GOTO  200 
WRITE  (LUTy  112)  ICODE 
GOTO  152 

200  GOTO  (210y  300y  400y  500)  ICODE 
C 

C CHANGE  THE  HIGHWALL  HEIGHT 

C 

210  WRITE  (LUTy  211)  HWHT  (LUOy  IHB) 

READ  (LUTy  HEIGHT 

C 

C GET  THE  OLD  ‘BR'  AND  THE  NEW  “BR“ 

C 

215  CALL  TSDBR  (HWHT  (LUOy  IHB)y  HWSLl  (LUOy  lHB)y 
> HWSLF  (LUOy  lHB)y  BROLD) 

CALL  TSDBR  (HEIGHTy  HWSLl  (LUOy  IHB)y  HWSLF  (LUOy  IHB)y  BRNEW) 

C 

C IF  THE  NEW  HEIGHT  IS  LESS  THAN  THE  OLD  ONEy  JUST  UPDATE  TERRACES 

C 

IF  (HEIGHT  *LE*  HWHT  (LUOy  IHB))  GOTO  220 
C 

C IS  IT  THE  TOP  HIGHWALL/BENCH  PAIR  ? 

C 

IF  (IHB  ♦EQ»  NHBP  (LUO))  GOTO  217 
C 

C TEST  TO  SEE  IF  UPPER  BENCH  WILL  ALLOW  NEW  HEIGHT 

C 

IF  (BRNEW  *GT*  BROLD  + BENWF  (LUOy  IHB))  GOTO  225 
C 

C IS  IT  THE  BOTTOM  HIGHWALL/BENCH  PAIR  ? 

C 

IF  (IHB  *EQ*  1)  GOTO  220 
C 

C TEST  TO  SEE  IF  LOWER  BENCH  WILL  ALLOW  NEW  HEIGHT 

C 

217  IF  (BRNEW  ^GT*  BROLD  + BENWF  (LUOy  IHB-D)  GOTO  230 
C 

C IS  IT  THE  BOTTOM  HIGHWALL/BENCH  PAIR  ? 

C 

220  IF  (IHB  ♦EQ*  1)  GOTO  222 
C 

C UPDATE  BOTH  UPPER  AND  LOWER  TERRACE  WIDTHS 

C 

BENWF  (LUOy  IHB-1)  = BENWF  (LUOy  IHB-1)  - (BRNEW  - BROLD) 

C 

222  BENWF  (LUOy  IHB)  = BENWF  (LUOy  IHB)  - (BRNEW  - BROLD) 
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C 

C UPDATE  THE  HIGHWALL  HEIGHT 

C 

223  IE  (SPEC  .EQ*  2*)  GOTO  224 
IPTR  = 4 

CALL  TSBLA  < IPTR » IHD » HEIGHT y PARAM2 ) 

224  HUHT  (LUO,  IHB)  = HEIGHT 
GOTO  150 

C 

C ERROR  ->  NOT  ENOUGH  ROOH  ON  THE  TERRACE 

C 

225  I HDD  = IHB 

227  WRITE  (LUT,  226)  IHBB 
IF  (LER)  CALL  BELL 
IF  (LER)  CALL  TINPT  (IANS) 

GOTO  150 
C 

230  IHBB  = IHB  - 1 
GOTO  227 
C 


C CHANGE  THE  INITIAL  WIDTH  OF  THE  BENCH 

C 

300  WRITE  (LUT,  301)  BENWI  (LUO,  IHB) 

READ  (LUT,  t)  BENCH 
C 

C TEST  WIDTH*  IF  NEW  WIDTH  > OLD  WIDTH,  NO  PROBLEM 

C 

305  IF  (BENCH  *GE*  BENWI  (LUO,  IHB))  GOTO  322 
C 

C DOES  IT  WIPE  OUT  THE  TERRACE  ? 

C 

IF  ((BENWI  (LUO, IHB)  - BENCH )♦ LE * BENWF  (LUO, IHB))  GOTO  322 
WRITE  (LUT,  306)  BENWF  (LUO,  IHB),  BENWI  (LUO,  IHB) 

GOTO  300 
C 

C UPDATE  TERRACE  AND  BENCH 

C 

322  BENWF  (LUO,  IHB)  = BENWF  (LUO,  IHB)  - (BENWI  (LUO,  IHB)  - BENCH) 

323  IF  (SPCC  *EQ*  2*)  GOTO  325 
IPTR  = 1 

CALL  TSBLA  ( IPTR , IHB , BENCH , PARAM2 ) 

325  BENWI  (LUO,  IHB)  = BENCH 
GOTO  150 
C 

C CHANGE  THE  INITIAL  SLOPE  OF  THE  HIGHWALL 

C 

400  WRITE  (LUT,  401)  HWSLl  (LUO,  IHB) 

READ  (LUT,  t)  SLI 
C 


C IS  THIS  SLOPE  GREATER  THAN  THE  PREVIOUSLY  INPUT  FINAL  SLOPE  ? 

C 


405 

IF  (SLI 

♦ GE* 

HWSLF 

(LUO, 

IHB)  ) 

GOTO  432 

WRITE  (LUT, 
GOTO  400 

406) 

HWSLF 

(LUO, 

IHB) 

432 

CALL  TSDBR 

(HWHT 

(LUO, 

IHB)  , 

SLI , 

HWSLF  (LUO,  IHB),  BRNEW) 

CALL  TSDBR 

(HWHT 

(LUO, 

IHB)  , 

HWSLl 

(LUO,  IHB), 
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0255 
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0261 
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> HUfSLF  <LU0j  IHB)>  BRDLD) 

C 

C UPDATE  THE  TERRACE  WIDTH  AND  INITIAL  SLOPE 

C 

BENWF  iLUOf  IHB)  = BENWF  <LUO>  IHB)  + (BROLD  - BRNEW) 

434  IF  <SPCC  .EQ*  2*)  GOTO  436 
IPTR  = 5 

CALL  TSBLA  ( IPTR r IHB » SLI ? PARAN2 ) 

436  HWSLI  (LUO?  IHB)  = SLI 
GOTO  150 
C 

C CHANGE  THE  BENCH  LENGTH 

C 

500  WRITE  <LUT»  501)  BENLEN  (LUOr  IHB) 

READ  (LUT,  t)  BENLEN  (LUO,  IHB) 

IPTR  = 3 

IF  (SPCC  *EQ*  !♦)  CALL  TSBLA  ( IPTR , ICHB , PARAMl , PARAH2 ) 
GOTO  150 


C FORMAT  STATEMENTS 

C 

111  F0RMAT(/,5X"WHICH  HIGHWALL/BENCH  PAIR  DO  YOU  WISH  TO  CONSIDER 
>5X" (ENTER  A NUMBER  BETWEEN  1 AND  -12'  OR  ZERO  TO  QUIT  ->  _‘) 

C 

112  F0RMAT(/,2X,I2*  ? ERROR  ->  ILLEGAL  ENTRY*  RE-SELECT*->  _*) 

C 

151  FORMAT  (/,5X"WHERE  IS  YOUR  CHANGE  ON  WALL/BENCH  ♦■I2*  ?V, 
>5X"0  ->  NO  FURTHER  CHANGES"/, 

>5X"1  ->  HIGHWALL  HEIGHT"/, 

>5X"2  ->  BENCH  WIDTH"/, 

>5X"3  ->  INITIAL  SLOPE  OF  THE  HIGHWALL"/, 

>5X"4  ~>  LENGTH  OF  THE  BENCH"//, 

>5X- ENTER  YOUR  CHOICE  HERE  ~>  «") 

C 

211  F0RMAT(/,5X"CURRENT  HEIGHT  = "F7*2"  FEET"/, 

>5X"ENTER  YOUR  NEW  HEIGHT  HERE  ->  _") 

C 

226  FORMAT (/,5X" ERROR  ->  NOT  ENOUGH  ROOM  ON  BENCH  "12/ 

>5X"F0R  THAT  HEIGHT  IN  COMBINATION  WITH  THE  BENCH  WIDTH"/, 
>5X"AND  THE  PREVIOUSLY  REQUESTED  FINAL  SLOPES*  TRY  AGAIN*") 

C 

301  F0RMAT(/,5X"CURRENT  BENCH  WIDTH  = ‘ F7 * 2 " FEET "/ , 

>5X"ENTER  YOUR  NEW  BENCH  WIDTH  HERE  ~>  -.") 

C 

306  F0RMAT(/,5X"ERR0R  ->  BENCH  WIDTH  REQUESTED  IS  TOO  SMALL'/, 
>5X"CURRENT  TERRACE  WIDTH  IS  :"F7*i"  FEET"/, 

>5X"CURRENT  INITIAL  BENCH  WIDTH  IS  :"F7*1"  FEET*  RE-TRY"/) 

C 

401  FORMAT (/,5X "CURRENT  SLOPE  = "F5*2'  DEGREES"/ 

>5X"ENTER  YOUR  NEW  SLOPE  HERE  ”>  _") 

C 


406  F0RMAT(/,5X"ERR0R  ->  INITIAL  SLOPE  REQUESTED  IS"/, 
>5X'LESS  THAN  PREVIOUSLY  INPUT  FINAL  SLOPE  0F"F5*2,/ 
>5X " DEGREES  * RE-TRY  * " / ) 

501  FORMAT (/,5X" CURRENT  BENCH  LENGTH  = "F7 *1  "FEET"/ 

9 


'?  * / 
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>SX* ENTER  NEW  BENCH  LENGTH 


0279 

0280 
0281 
0282 

0283 

0284 

0285 

0286 


C 


1000  FORMAT  (IX "SELECT  ONE  OF  THE  FOLLOWING  :"/ 

> 1X"1  ~>  RETAIN  THE  CURRENT  BENCH  LENGTH(S)"/ 

> 1X"2  ->  RETAIN  THE  ANGLE(S)  DEFINED  BY  THE  CURRENT  DATA"/ 
>1X"ENTER  YOUR  SELECTION 

END 

END$ 
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0032 
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0034 

0035 

0036 
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0038 

0039 

0040 
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0044 
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FTN4 

C 


SUBROUTINE  TSSCF 

TRUCK  AND  SHOVEL  : SELECTIVE  CHANGES  TO  FINAL  SLOPES 


C 

C 

C 

C 

C 

C 

C 

C 


LEVEL  3 

THIS  F>:OUTINE  SCHEDULES  SELECTIVE  CHANGES  TO  FINAL  SLOPE  VALUES 
TSSCF  IS  ACCESSED  BY  TSGE  AND  SWAPPED  IN  BY  PROGRAh  TSSCO 
THE  CALLING  SEQUENCE  IS  : CALL  ISSCF 


C 

C SUBROUTINES  SCHEDULED? 


C ERASE  (TCS) 

C HOHE  <TCS) 

C TSDBR  (CLAIM) 

C TSSCK  (CLAIM) 

C 


C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 

C 


LOCAL  variables: 

AVAIL  ~>  CURRENT  AVAILABLE  BENCH 

EAT  ->  AMOUNT  OF  BENCH  “EATEN"  BY  NEW  FINAL  SLOPE 
EATA  ->  AMOUNT  OF  BENCH  ABOVE  EATEN  BY  NEW  FINAL  SLOPE 

EATB  ~>  AMOUNT  OF  BENCH  BELOW  EATEN  BY  NEW  FINAL  SLOPE 

IANS  ->  ANSWER  CELL 

NUMl  ->  BENCH  NUMBER  OF  BENCH  BELOW 

NUMB  ">  CURRENT  BENCH  NUMBER 

SLMIN  ~>  MINIMUM  SLOPE  REQUEST 

SLMINA  ~>  MINIMUM  SLOPE  BASED  ON  BENCH  ABOVE 

SLMINB  ->  MINIMUM  SLOPE  BASED  ON  BENCH  BELOW 

SLOUT  ->  MINIMUM  SLOPE  PRESENTED  TO  THE  USER 

SLPDES  ~>  USER'S  SLOPE  REQUEST 


C 


C THIS  ROUTINE  WAS  WRITTEN  BY  EASTMAN  AND  MODIFIED  BY  GREEN 
C 

C CLAIM  RELEASE  1*0  - APRIL  1>  1980 

C 

C 

C TEKTRONIX  COMMON 

C 

COMMON  ITEK  (45) 


C 


C LOGICAL  UNITS  AND  COMMON  LOCATION 

C 


COMMON  I ARRY ( 5 ) y I AR Y2 ( 5 ) > LER » LUF » LUL 
C 

C POINTERS 

C 

COMMON  EXIT  , IANM(3) » ICLl (2) » IGEN(3) , 1GRW(5) 
COMMON  lOPTN  y I0VR(7) ? IHB  , IS0C(6) y ISUB(8) 
COMMON  ISURC6) y IT0P(9) y 1VEG(2) yLEXIT  y LUO 
COMMON  MODE  yNANM  yNCLI  yNGEN  yNGRW 
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0055 

0056 

0057 

0058 

0059 

0060 

0061 

0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 

0080 

0081 

0082 

0083 

0084 

0085 

0086 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 

0100 

0101 

0102 

0103 

0104 

0105 

0106 

0107 

0108 

0109 

0110 


COMHON  NOOR  »NSECTS  »NSOC  jHSUB  >NSUR 

COMMON  NTOP  y NU  yNVEG 


C 

C GRADING  PARAMETERS 

C 

COMMON  AREA  < 5 ) y DENLEN ( 5 y 1 0 ) y BENW I ( 5 y 1 0 ) y COGO  y GCPA  < 5 ) 

COMMON  SPCCC5) yHWHf (5y 10) yHWSLl(5y 10) yNHBP(5) yPCEQ19(4) 
COMMON  BENWP(5y 10) yREHCPYCS) yREH00L(5) yHWSLF(5ylO) yUSR 
C 

C CATEGORY  TEXT 

C 

COMMON  ANIM(23y 13) yCLMA(13y 13) yGHES(15yl3) yGWHY(22y 13) 
COMMON  00BD(llyl3)ySBSL(13)y  SCEC<33y 13) y GWHY(44y 13) 

COMMON  TPSL(49y 13) yOGTA(15y 13) 

C 

C EXPECTATION  VALUES 

C 

COMMON  ANIMAL(13y6) yCLIMAT(8y6) y GENDES(8y6) y GRWHYD ( 19 y 6 ) 
COMMON  0VRBDN(28y6) yS0CECN(29y6) y SUESOl ( 30 y 6 ) y SURHYD ( 23 y 6 ) 
COMMON  T0PS0I(33y6) y VEGETA < 10 y 6 ) 

C 

C CATEGORY  RESPONSES 

C 

COMMON  RANIMAC3) yRCLIMA(2) yRGENDE(3) yRGRUHY<5) 

COMMON  ROVRBD ( 7 y 1 0 ) y RSOCEC ( 6 ) y RSUBSO ( 8 ) y RSURH Y ( 6 ) 

COMMON  RT0PS0(9) yRVEGET(2) 

C 

C PEASIyTECONyOPUSE  SUBSYSTEM  PARAMETERS 

C 

COMMON  CAAHM  y CABAH  y CABFN ( 3 ) y CABFP ( 3 ) y CABHM 

COMMON  CABS  < 2 ) y C AC  y CACP  y CADF  y C ADH 

COMMON  CADSyCAEAF  y CAHSAF y CAHSTS y CAIP 

COMMON  CAR3FC  y CASE  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y FAVG ( 5 ) y PFSTSP  y PFAC  y RCLTEC ( 29  y 34 ) 

COMMON  TCAR<5) yTHICK(lO) yTHKTSyTTL(40) 

C 


C 


INTEGER  EXI T y CLMA  y GDES  y GUH Y y OVBD  y SBSL 
INTEGER  SCEC  y SWHY  y TPSL  y VGTA  y ANIM 
INTEGER  CL 1 MAT yGENDESy GRWHYD yOVRBDN 
INTEGER  SOCECNySUBSOIy SURHYD yfOPSOl 
INTEGER  VEGETA y ANIMAL 

INTEGER  RCLIMAy RGENDEyRGRWHYy ROVRBD y RSOCEC 
INTEGER  RSUBSO  y RSURH Y y RTOPSO  y RVEGET y RANIMA 
INTEGER  RCLTEC yTTL 

INTEGER  COMMON  (1) 


EQUIVALENCE 

(COMMON 

(1) 

y ITEM 

EQUIVALENCE 

(XARRY 

(1)  y 

LUT) 

EQUIVALENCE 

<IARY2 

(1)  y 

ISTRK) 

EQUIVALENCE 

(IARY2 

(2)  y 

ISECT) 

EQUIVALENCE 

(1ARY2 

(3)  y 

ICODE) 

EQUIVALENCE 

(IARY2 

(4)  y 

LEN) 

C 

C 


LOGICAL  LER 
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0111 

0112 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120 

0121 

0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 

0161 

0162 

0163 

0164 

0165 

0166 


C 

C 

C 

C 

C 


C 

C 

C 


C 

C 

C 

C 

C 

C 

C 

C 


C 

C 

c 

c 

c 

c 

c 

c 

c 

c 


c 

c 

c 

c 


c 


COMMON  /ALTRN/  ALTN 
INTEGER  ALTN  <6j4) 


WRITE  THE  TITLE 

EATA  = 0* 

EATB  = 0* 

IF  (LER)  CALL  ERASE 
IF  (LER)  CALL  HOME 
IF  (MODE  ♦EQ*  4)  GOTO  30 
WRITE  (LUT»  25)  (ALTN  (LUO»  J)r  J = 1»  4) 

GET  HIGHWALL/BENCH  NUMBER  OF  EDIT 

30  WRITE(LUTy31)  NHBP(LUO) 

33  READ(LUT?:(0  NUMB 

IF(NUMB.EQ*0)  RETURN 

1F(NUMB*GT*0*AND*NUMB.LE«NHBP(LU0) ) GOTO  40 
WRITE(LUT>32)  NHBP(LUO) 

GOTO  33 

CALCULATE  THE  MINIMUM  FINAL  SLOPE*  IF  THIS  IS  THE  FIRST 
PAIRj  THERE  IS  NO  NEED  TO  CHECK-  BELOW* 


40  IF  (NUMB  *EQ*  1)  GOTO  50 

FIND  OUT  HOW  MUCH  THE  SLOPE  OF 
EATS  OUT  OF  BENCH  “NUMB  --  1“ 

CALL  TSDBR  (HWHT  (LUO?  NUMB  - 
> HWSLF  (LUO»  NUMB  - 1)? 


HIGHWALL/BENCH  PAIR  “NUMB  - 1“ 

l)j  HWSLI  (LUOj  numb  - l)y 
EATE) 


CALCULATE  THE  AVAILABLE  BENCH 
AVAIL  = BENWI  (LUO.  NUMB-1)  - EATB 


CALCULATE  THE  MINIMUM  SLOPE  FOR  HIGHWALL  “NUMB“  & BENCH  “NUMB  ~1‘ 

CALL  TSSCK  (AVAIL,  HWSLI  (LUO,  NUMB),  HWHT  (LUO,  NUMB),  SLMINB) 

IF  THIS  IS  THE  TOP  BENCH,  THEN  THE  AVAILABLE  BENCH  IS  THE  SAME 
AS  THE  INITIAL  BENCH  WIDTH*  OTHERWISE,  WE  MUST  CALCULATE  IT 

45  IF  (NUMB  *LT*  NHBP  (LUO))  GOTO  50 
AVAIL  = BENWI  (LUO,  NUMB) 

GOTO  60 


CHECK  HOW  MUCH  BENCH  THE  FINAL  SLOPE  FOR  HIGHWALL  “NUMB  - 1“ 
EATS  OUT  OF  BENCH  "NUMB“ 

50  CALL  TSDBR  (HWHT  (LUO,  NUMB  T 1 ) , HWSLI  (LUO,  NUMB  T 1 ) , 

> HWSLF  (LUO,  NUMB  +1),  EATA) 

AVAIL  = BENWI (LUO, NUMB)  - EATA 
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0167 

0168 

0169 

0170 

0171 

0172 

0173 

0174 

0175 

0176 

0177 

0178 

0179 

0180 

0181 

0182 

0183 

0184 

0185 

0186 

0187 

0188 

0189 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

0197 

0198 

0199 

0200 

0201 

0202 

0203 

0204 

0205 

0206 

0207 

0208 

0209 

0210 

0211 

0212 

0213 

0214 

0215 

0216 

0217 

0218 

0219 

0220 

0221 

n' 

A** 


C 

c 

c 


CALCULATL-  THE  MINIMUM  SLOPE  REOUESTABLEy  BASED  ON  HIGHWALL 
•NUMB*  AND  BENCH  'NUMB' 


60  CALL  TSSCK  <AOAIL»  HWSLI  (LUO,  NUMB), 


HWHT  (LUO,  NUMB),  SLMINA) 


C 

C 

C 

C 

C 


IF  IHE  MINIMUM  SLOPE  BASED  ON  THE  BENCH  BELOW  IS  NOT  LEGS  THAN 
THE  MINIMUM  SLOPE  BASED  ON  BENCH  “NUMB“,  THEN  SET  SLMINB 
TO  THE  MINIMUM  SLOPE 


IF  (SLMINA  *LT*  SLMINB)  GOTO  70 


C 

C 

C 


IF  THE  REVERSE  IS  TRUE,  SET  SLMINA  TO  THE  MINIMUM 


IF  (SLMINB  ♦LT^SLMINA)  GOTO  80 
NUMl  = NUMB  - 1 

SLOUT=FLOAT(  IFIX(SLMINB)«a00»  + *01 ) )/100* 

WRITE (LUT, 61)  SL0U7 , NUMl , NUMB 
GOTO  110 

70  NUMl  = NUMB  - 1 

SLOUT=FLOAT  ( IFIX  ( SLMINB)<aOO  ♦ + . 01 ) ) /lOO  * 

WRITE(LUT,71)  SL0UT,NUM1 
GOTO  110 

80  SL0UT=-FL0AT(IFIX(SLMINA)^a00*  + *01 ) )/100* 

WRITE(LUT,71)  SLOUI,NUMB 

110  SLMIN=FL0AT(IFIX(AMAX1  (SLMINA,  SLMINB ):<aOO»-f>  01 ) )/100* 
SLMAX=FL0AT(1FIX(AMIN1(19* , HWSLI ( LUO , NUMB ) ))^100* ) )/100* 
1F(LU0*EQ*  1 ) SLMAX=FL0AT(IFIX(AMIN1(5*7,HWSLI  (LUO,NUMB)  ))JC100»  ) ) 
>/100* 

IF(M0DE*EQ*4)  SLMAX=FLOAT  ( IFIX ( HWSLI  ( LUO , NUMB ) :«cl00 ♦ ) )/100» 
IF(SLMAX.GT*SLMIN)  GOTO  114 
WRITE (LUT, 62) 

IF(LER)  CALL  BELL 
IF(LER)  CALL  TINPT(ICHAR) 

RETURN 

114  WRITE(LUT ,111)  NUMB 
REAIKLUT,)!?)  SLPDES 

SLPDES  = FL0AT(1FIX(SLPDES5^^100♦  ) )/100* 

IF ( SLPDES *GE*SLMIN* AND* SLPDES *LE.SLMAX)  GOTO  120 
WRITE(LUT, 112)  SLMIN,SLMAX 
RE AD (LUT, 113)  lANG^ 

IF(1ANS*EQ*2HYE)  110,  30 


IF(NUMB*EQ* 1 ) GOTO  125 

BENWF  (LUO,  NUMB- 1 ) =•'  BENWI  ( LUO, NUMB- 1)  - EATB  - EAT 
IF(BENWF(LU0,NUMB-1) *LT*0* ) GOTO  130 
125  BENWF (LUO, NUMB)  = BENWI  (LUO, NUMB)  - EATA  - EAT 
IF (BENWF (LUO, NUMB) vLT*0* ) GOTO  130 


C 

C 

C 

C 

C 


EVERYTHING  IS  OK  UPDATE  INFORMATION  BY  CALCULATING 

HOW  MUCH  BENCH  THIS  FINAL  SLOPE  EATS 


C 

C 

C 


UPDATE  BENCH  WIDTHS 
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0223 

C 

0224 

C 

0225 

0226 
0227 

C 

0228 

C 

0229 

C 

0230 

C 

0231 

0232 

130 

0233 

C 

0234 

C 

0235 

C 

0236 

25 

0237 

C 

0238 

0239 

31 

0240 

C 

0241 

32 

0242 

C 

0243 

0244 

61 

0245 

C 

0246 

0247 

0248 

0249 

62 

0250 

C 

0251 

0252 

71 

0253 

C 

0254 

111 

0255 

C 

0256 

0257 

112 

0258 

C 

0259 

113 

0260 

0261 

C 

0262 

END$ 

UPDATE  FINAL  SLOPE  AND  BRANCH  TO  30 

HWSLF  < LUO j NUMB)  = SLPDES 

GOTO  30 

ADJUST  SLPDES  TO  APPROPRIATE  VALUE 

SLPDES=SLPDES+*01 

GOTO  120 

FORMAT  STATEMENTS 

FORMAT ( / ? 5X » 4 A2  * ALTERNATIVE ' // ) 

FORMAT(/>b'X*WHICH  HIGHWALL/BENCH  PAIR  NUMBER  DO  YOU  WISH'/ 
3jcSX"T0  CONSIDER  ? (ENTER  1 TO  'I2‘  OR  ZERO  TO  QUIT)  ->  _*) 

FORMAT(/?SX*ERROR  ~>  NUMBER  MUST  BE  BETWEEN  1 AND  "12-  ->_• 

F0RMAT(/»5X'MINIMUM  SLOPE  REQUESTABLE  IS  *F5*2"  DEGREES*/ 
)ic5X" BENCHES  'I2*  AND  *12*  WILL  BE  APPROXIMATELY  ZERO*') 

F0RMAT(/5X'GRADING  TO  MAXIMUM  PERMISSABLE  FINAL  SLOPES'/ 

> 5X*IS  NOT  GEOMETRICALLY  POSSIBLE  ON  THIS  HI6HWALL*/ 

YOU'LL  HAVE  TO  RE-DEFINE  THE  MINE  PLAN){C3<«'/ 

>/  5X'HIT  THE  RETURN  KEY  TO  CONTINUE ♦♦*♦♦_' ) 

FORMATC/jUX'MINIMUM  slope  REQUESTABLE  IS  'Ft5*2‘  DEGREES* '/ 
)fc5X' BENCH  '12'  WILL  BE  APPROXIMATELY  ZERO*') 

F0RMAT(/>UX'FINAL  slope  for  HIGHWALL  # '12'  ->  -.') 

FORMAT(/,UX'ERROR  ->  SLOPE  MUST  BE  BETWEEN  'F5*2'  DEGREES?' 
3f:5X'AND  'FU*2'  DEGREES*  TRY  AGAIN  ? (YES  OR  NO)  ~>  -') 

F0RMAT(A2) 

END 


) 


/? 
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0001 
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0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 


FTN4 

SUBROUTINE  TSSCK  < AOAIL y SLI j HEIGHT , SLNIN ) 

C TRUCK  AND  SHOOEL  : SLOPE  CHECK  

C 

C LEVEL  5 
C 

C THIS  ROUTINE  CHECKS  THE  MINIMUM  REOUESTABLE  SLOPE y BASED  ON 

C THE  CURRENT  HIGHWALL  / BENCH  DESCRIPTION 

C 

C THE  CALLING  SEQUENCE  IS  t 
C 

C CALL  TSSCK  ( AVAIL y SLI y HEIGHT y SLMIN ) 

C 

C WHERE 
C 

C AVAIL  ->  AVAILABLE  DENCH 

C SLI  ->  INITIAL  HIGHWALL  SLOPE 

C HEIGHT  ~>  HIGHWALL  HEIGHT 

C SLMIN  ->  MINIMUM  SLOPE 

C 


0021 

0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 


C LOCAL  VARIABLES  ARE  DEFINED  IN  THE  PROGRAMMER'S  MANUAL 
C 

C THIS  ROUTINE  WAS  WRITTEN  BY  EASTMAN 
C 

C CLAIM  RELEASE  1.0  - APRIL  ly  1980 

C =======:==========:  = ==  = ==============================  = =====r======:  = =============:================  = 

C 

RSLI  = SLI  t .01745 

ADJl  = HEIGHT  / TAN  (RSLI) 

ADJ2  = ADJl  I <2  :4c  AVAIL) 

RSLMIN  = ATAN  ( HEIGHT  / ADJ2  ) 

SLMIN  = RSLMIN  / .01745 

RETURN 

END 

END$ 


V 
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0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 
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FTN4 

SUBROUTINE  TSST 

0 TRUCK  AND  SHOOEL  SUMMARY  TABLE 

C 

C LEVEL  3 
C 

C A SUMMARY  TABLE  OF  VOLUMES y COSTS , AND  AREA  FOR  GRADING  THE 

C TRUCK  AND  SHOVEL  PRODUCED  SPOILS  AND  REHANDLE  VOLUMES  AND  COSTS 

C ARE  PRESENTED  ON  EITHER  THE  TERMINAL  OR  THE  LINE  PRINTER 

C 

C THE  CALLING  SEQUENCE  IS  t CALL  TSST 

C 

C 

C TSST  IS  ACCESSED  BY  TSGE  AND  SWAPPED  IN  BY  PROGRAM  TSSTX 
C 

C SUBROUTINES  SCHEDULED: 

C 

C BELL  (TCS) 

C ERASE  (TCS) 

C HOME  (TCS) 

C TINPT  (TCS) 

C TSVCA  (CLAIM) 

C 

c LOCAL  variables: 

C 

C CPAH  ->  COST  PER  ACRE  FOR  REHANDLE 

C CST  ->  GRADING  COST  ARRAY 

C IANS  “>  ANSWER  CELL 

C REHTOT  ->  REHANDLE  TOTAL 

C TOTCST  ->  TOTAL  COST 

C TOTVOL  ->  TOTAL  VOLUME 

C VOL  ->  VOLUME  GRADED  ARRAY 

C 

C THIS  ROUTINE  WAS  WRITTEN  BY  GREEN 
C 

C CLAIM  RELEASE  1*0  - APRIL  1j  1980 

C 

C TEKTRONIX  COMMON 

C 

COMMON  ITEK  (45) 

C 

C LOGICAL  UNITS  AND  COMMON  LOCATION 

C 

COMMON  I ARR Y ( 5 ) r I ARY2 ( 5 ) t LER , LUF  j LUL 
C 

C POINTERS 

C 

COMMON  EXIT  , IANM(3) y ICLl (2) y IGEN(3) y IGRW(5) 

COMMON  lOPTN  yI0VR(7)yIHB  y I SOC ( 6 ) y I SUB ( 8 ) 

COMMON  ISUR(6) y 1T0P(9) y 1VEG(2) yLEXIT  yLUO 
COMMON  MODE  yNANM  yNCLl  yNGEN  yNGRW 

COMMON  NOVR  yNSECTS  yNSOC  yNSUB  yNSUR 

COMMON  NTOP  ,NU  yNVEG 
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0055  C 

0056  C 

0057  C 

0058 

0059 

0060 

0061  C 

0062  C 

0063  C 

0064 

0065 

0066 

0067  C 

0068  C 

0069  C 

0070 

0071 

0072 

0073  C 

0074  C 

0075  C 

0076 

0077 

0078 

0079  C 

0080  C 

0081  C 

0082 

0083 

0084 

0085 

0086 

0087 

0088  C 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097  C 

0098 

0099 

0100 
0101 
0102 

0103 

0104 

0105  C 

0106 

0107  C 

0108  C 

0109 

0110 


GRADING  PARAMETERS 

COMMON  AREA ( 5 ) y BENLEN  < 5 y 1 0 ) y BENWI ( 5 y 1 0 ) y C060  y GCPA ( 5 ) 
COMMON  SPCCC5)  yHWHT(5y  10)  yHWSLKSy  10)  yNHBP<5)  yPCEQ19(4) 
COMMON  BENWF-  (5y  10)  y REHCPY ( 5 ) y REHOOL ( 5 ) y HWSLF ( 5 y 10 ) yUSR 

CATEGORY  TEXT 

COMMON  ANIM(23y 13) yCLMA(13y 13) yGDESdSy 13) yGWHY(22y 13) 
COMMON  00BD(llyl3)ySBSL(13)y  SCEC ( 33 y 13 ) y SWHY ( 44 y 1 3 ) 
COMMON  TPSL(49y 13) yy6TA(15y 13) 

EXPECTATION  VALUES 

COMMON  ANIMAL(13y6) yCLIMAT<8y6) yGENDES<8y6) yGRWHYD(19y 
COMMON  OVRBDN ( 28  y 6 ) y SOCECN ( 29  y 6 ) y BUBSO I ( 30  y 6 ) y SURH YD  < 2 
COMMON  TOPSOI < 33  y 6 ) y VEGETA ( 10  y 6 ) 

CATEGORY  RESPONSES 


COMMON  RANIMAC3) yRCLIMA(2) yRGENDE<3) yRGRWHY<5) 
COMMON  RO VRBD (7yl0)yRSGCEC(6)y  RSUBSO ( 8 ) y RSURH Y ( 6 ) 
COMMON  RT0PS0(9) yRVEGEI <2) 


EEASlylECONyOPUSE  SUBSYSTEM  PARAMETERS 


COMMON  CAAHM  y C ADAH  y CABF  N ( 3 ) y CABFP  < 3 ) y CABHM 

COMMON  CABS  < 2 ) y C AC  y CACP  y CADF  y CADH 

COMMON  CADS  y CAEAF  y CAHSAF  y CAHSTS  y CAI P 

COMMON  CAR3FC  y CASF  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y F A VG ( 5 ) y PF  STSP  y PF  AC  y RCLTEC  < 29  y 34 ) 

COMMON  TCAR(5) y THICK(IO) y THKTS y TTL ( 40 ) 


INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 

INTEGER 


EXI T y CLMA  y GDES  y GUH Y y OVBD  y SBSL 
SCEC  y SWH Y y TPSL  y VGTA  y ANl M 
CL IMAT  y GENDES  y 6RWH YD  y OVRBDN 
SOCECN  y SUBSO I y SURH YD  y TOPSOI 
VEGETA y ANIMAL 

RCL IMA  y RGENDE  y RGRWHY  y ROVRBD  y RSOCEC 
RSUBSO  y RSURHY  y RTOPSO  y RVE6ET  y RANIMA 
RCLTECy TTL 


INTEGER  COMMON  <1) 

(COMMON  (1) 
(lARRY  (l)y 


EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 

EQUIVALENCE 


(IARY2  (l)y 
(IARY2  <2)y 
(IARY2  (3)y 
(IARY2  (4)y 


y ITEM  (1)) 
LUT) 

ISTRK) 

ISECT) 

I CODE) 

LEN) 


LOGICAL  LER 


COMMON  /ALTRN/  ALTN 
INTEGER  ALTN  (6y  4) 
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W Cs 


0111 

0112 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120 
0121 
0122 

0123 

0124 


0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 
0161 
0162 

0163 

0164 

0165 

0166 


C 

C 

C 


C 

C 

C 


DIMENSION  VOL  (10) > CST  (10) 

GET  THE  VOLUMES  AND  COSTS 

CALL  TSVCA  <VOL>  CSTy  TOTVOLt  TOTCST) 
IF  (lOPTN  *EQ*  2)  GOTO  300 

WRITE  HEADINGS 

IF  <LER)  CALL  ERASE 
IF  (LER)  CALL  HOME 
WRITE  <LUL»  1000) 

IF  (MODE  *NE*  4)  GOTO  26 


0125 

WRITE 

(LUL, 

35) 

0126 

GOTO 

27 

0127 

26 

WRITE 

(LUL, 

30)  (ALTN  (LUO 

, J),  J= 

0128 

27 

WRITE 

(LUL, 

31) 

0129 

IF  (LER)  CALL  HOME 

0130 

50 

GO  TO 

(51, 

52,  53)  RGENDE 

(2) 

0131 

51 

WRITE 

(LUL, 

1001) 

0132 

GO  TO 

55 

0133 

52 

WRITE 

(LUL, 

1002) 

0134 

60  TO 

55 

0135 

0136 

C 

53 

WRITE 

(LUL, 

1003) 

0137 

55 

WRITE 

(LUL, 

1020) 

0138 

WRITE 

(LUL, 

1010) 

0139 

0140 

C 

WRITE 

(LUL, 

1020) 

0141 

C 

LOOP 

THROUGH 

1 THE  WALL/BENCH 

PAIRS 

0142 

C 

0143 

75 

DO  100  1=1, 

NHBP  (LUO) 

0144 

100 

WRITE 

(LUL, 

1030)  I,  HWSLI 

(LUO,  I) 

> BENWI  (LUOy  1)  > BENWF  (LUO?  I)>  HWHT  (LUO»  1)»  BENLEN  (LUO»  1)» 


VOL  <1)t  CST  (I) 


C 

C 

C 


C 

C 

C 


C 


C 

C 

C 


C 


WRITE  TOTALS 


210  WRITE  (LULt  1020) 

WRITE  (LULj  1040)  TOTVOL?  COGOr  TOTCST,  AREA  (LUO),  GCPA  (LUO) 

IF  NOT  OPENING  CUT,  WRITE  OUI  REHANDLE  TOTALS  AND  GRAND  TOTALS 

300  IF  (R6ENDE  (2)*EQ*1)  GOTO  (230,  250)  lOPTN 
REHTOT  = REHVOL  (LUO)  REHCPY  (LU0)/100* 

CALCULATE  CST  PER  ACRE  FOR  REHANDLE 
CPAH  = REHIOT  / AREA  (LUO) 

TOTCST  = TOTCST  + REHTOT 

CALCULAIE  GRAND  TOTAL  COST  PER  ACRE 

GCPA  (LUO)  = TOTCST/AREA  (LUO) 

IF  (lOPTN  »EQ»  2)  RETURN 

WRITE  (LUL,  1050)  REHVOL  (LUO),  REHCPY  (LUO),  REHTOT,  CPAH, 
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0167 

0168 

0169 

0170 

0171 

0172 

0173 

0174 

0175 

0176 

0177 

0178 

0179 

0180 
0181 
0182 

0183 

0184 

0185 

0186 

0187 

0188 
0189' 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

0197 

0198 

0199 

0200 
0201 
0202 

0203 

0204 

0205 

0206 

0207 

0208 

0209 

0210 
0211 
0212 

0213 

0214 

0215 

0216 

0217 

0218 
0219 


t TOTCSTj  GCPA  (LUO) 

230  IF  (LUL*NE.LUT)  GOTO  250 
IF  <*N0T4LER)  goto  250 
WRITE  (LUT»  1045) 

CALL  BELL 

CALL  TINPT  (IANS) 

C CALL  ERASE 

250  CONTINUE 
RETURN 
C 

C FORHAT  STATEMENTS 

C 

1000  FORMAT  (IHl) 

C 

30  FORMAT  “4A2*  ALTERNATIVE  ) 

C 

31  FORMAT  (IX'TRUCK  ^ SHOVEL  GRADING*) 

C 

35  FORMAT  (18X*5(c)Jc>K)|c>Jc  GRADE  RUN  * ) 

C 

1001  FORMAT  (2/>  51X*0PENIN6  CUT  OPTION*  ) 

C 

1002  FORMAT  <2/y  51X"MINE  RUN  OPTION*  ) 

C 

1003  FORMAT  (2/>  51X*FINAL  CUT  OPTION*  ) 

C 

1010  FORMAT  (lX*H/B*lX*)(fHW  SLOPES-DE6:4i  * IX 

> * BENCHES  (FT)  t HW  HGT  *BEN  LEN)i:VOL  GRADED)^  * 7X  * :«:  * / 

> 1X*N0»  )^^lNITIAU{^FINAL)^^INITIAU^c  FINAL  f IX 

> *(FEET)  t (FEET)  t (CU  YDS)  yH  COST^f:*) 


1020  FORMAT  (IX,  71  ( 


) ) 


1030  FORMAT  (2X,  12,  lX*Xc*F5*2,  2X " “ F5 .2  * *F5  ♦ 1 , 2X 

> *)^:*F5*1,  1X*)*:*F6*1,  2X*)^'F6*1,  1X*)K*F9*1,  lX‘fF7*2y  lX*3|c‘) 


1040  FORMAT  (/5X,  ‘TOTAL  VOLUME  GRADED*7X* 


*F12*1*  CUBIC  YARDS.*/ 


5X,  ‘COST  PER  CU.  YD  OF  GRADING: ‘8X,  F5.1‘  CENTS.*/ 
5X,  "TOTAL  COST  OF  GRADING  : $*F12.2/ 


5X,  ‘AREA  COVERED  BY  SPOILS 
5X,  *COST  PER  ACRE  OF  GRADING 


*5X,  F8.1"  ACRES. ■/ 
$*F12.2/) 


1050  FORMAT  (5X,  ‘VOLUME  OF  REHANDLE"14X 


s ♦ ir 


F12.1*  CUBIC  YARDS.*/ 


5X,  ‘COST  PER  CUBIC  YARD  FOR  REHANDLE:  ‘7X,  F5.1*  CENTS. */ 


5X,  ‘TOTAL  COST  OF  REHANDLE 
5X,  ‘COST  PER  ACRE  FOR  REHANDLE 
/,  5X,  ‘GRAND  TOTAL  COST 

5X,  'GRAND  TOTAL  COST  PER  ACRE 


$*F12.2/ 
$‘F12.2/ 
$*F12.2/ 
$*F12.2  ) 


1045  FORMAT  (/*HIT  RETURN  KEY  TO  ERASE  AND  CONTINUE...  _*) 


C 


END$ 


END 
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0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 


FTN4 

SUBROUTINE  TSSTP 

C TRUCK  AND  SHOVEL  ~ SUNHARY  TABLE  (CALCOhP  PLOTTER) 

C 

C LEVEL  4 
C 

C TSSTP  DISPLAYS  A SUMMARY  lABLE  OF  VOLUMES,  COSTS,  AND 

C AREAS  FOR  THE  TRUCK  AND  SHOVEL  MINE*  THE  TABLE  IS  EITHER 

C PRESENTED  ON  THE  TERMINAL  OR  THE  CALCOMP  PLOTTER 

C 

C THE  CALLING  SEQUENCE  IS  t CALL  TSSTP 

C 

C 

C TSSTP  IS  ACCESSED  BY  TSXST  AND  SWAPPED  IN  BY  PROGRAM  TSSTO 
C 

C SUBROUTINES  SCHEDULED? 

C 

C ANMOD  <TCS) 

C DRWAB  <TCS) 

C MOVAB  (TCS) 

C TSVCA  (CLAIM) 

C 

c LOCAL  variables: 

C 

C CST  -•>  COST  INCREMENT 

C IHGT  ->  ‘HEIGHT*  OF  THE  7 ABLE 

C ITCA  ~>  TABLE  COMMAND  ARRAY 

C LUD  ~>  LOGICAL  UNIT  TO  DISPLAY  TO 

C REHTOT  “>  REHANDLE  TOTALS 

C TOTCST  “>  TOTAL  COST 

C TOTVOL  ->  TOTAL  VOLUME 

C VOL  ~>  VOLUME  INCREMENT 

C 

C THIS  ROUTINE  WAS  WRITTEN  BY  GREEN 
C 

C CLAIM  RELEASE  1*0  - APRIL  1,  1980 

C 

C 

C TEKTRONIX  COMMON 

C 

COMMON  ITEK  (45) 

C 

C LOGICAL  UNITS  AND  COMMON  LOCATION 

C 


0046  COMMON  I ARRY  < 5 ) , I AR Y2 ( 5 ) , LER , LUF , LUL 

0047  C 

0048  C POINTERS 

0049  C 

0050  COMMON  EXIT  , I ANM < 3 ) , ICLI < 2 ) , IGEN ( 3 ) , IGRW ( 5 ) 

0051  COMMON  lOPTN  ,I0VR(7),IHB  , ISOC < 6 ) , I SUB < 8 ) 

0052  COMMON  ISUR(6) , 1T0P(9) , I VEG < 2 ) , LEXIT  ,LUO 

0053  COMMON  MODE  ,NANM  ,NCLI  ,NGEN  ,NGRW 

0054  COMMON  NOVR  ,NSECTS  ,NSOC  ,NSUB  ,NSUR 
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0055 

0056 

0057 

0058 

0059 

0060 
0061 
0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 

0072 

0073 

0074 

0075 

0076 

0077 

0078 

0079 
OOSO 
0081 
0082 

0083 

0084 

0085 

0086 

0087 

0088 

0089 

0090 

0091 

0092 

0093 

0094 

0095 

0096 

0097 

0098 

0099 


COMMON  NTOP 


NO 


NVE.6 


0106 

0107 

0108 

0109 

0110 


C 

C 

C 


C 

C 

C 


C 

c 

c 


c 

c 

c 


c 

c 

c 


c 


c 


c 

c 

c 


GRADING  PARAMETERS 


COMMON  AREA  < 5 ) y BENLEN ( 5 y 1 0 ) » BENWI ( 5 y 1 0 ) y COGO  y GCPA  < 5 ) 

COMMON  SPCC<5) yHWHT<5y 10) yHWSLl(5ylO) yNHBP<5) yPCEQ19(4) 
COMMON  BENWP ( 5 y 1 0 ) y REHCP Y ( 5 ) y REHOOL  < 5 ) y HWSLF ( 5 y 1 0 ) y USR 

CATEGORY  TEXT 

COMMON  ANIM<23y 13) yCLMA(13y 13) y GDES < 15 y 13 ) y GWHY ( 22 y 13 ) 
COMMON  00BLKllyl3)ySBSL(13)y  SCEC(33y 13) y SWHY(44y 13) 

COMMON  TPSL(49y 13) yOGTA(15y 13) 

I 

I 

EXPECTATION  VALUES 

COMMON  ANIMAL(13y6) yCLIMAT(8y6) yGENDES(8y6) yGRWHYD<19y6) 
COMMON  OVRBDN ( 28  y 6 ) y SOCECN ( 29  y 6 ) y SUBSOI ( 30  y 6 ) y SURH YD  < 23  y 6 ) 
COMMON  T0PS0I(33y6) y VEGETA ( 10 y 6 ) 

CATEGORY  RESPONSES 

COMMON  RANIMA(3) y RCLIMA ( 2 ) y RGENDE < 3 ) yRGRWHYCS) 

COMMON  R0VRBD(7y 10) yRS0CEC(6) yRSUBS0(8) yRSURHY(6) 

COMMON  RT0PS0(9) yRVE6ET<2) 

FEASIyfECONyOPUSE  SUBSYSTEM  PARAMETERS 

COMMON  CA ARM  y C ABAH  y C ABFN ( 3 ) y CABFP ( 3 ) y CABHM 

COMMON  CABS ( 2 ) y C AC  y C ACP  y CADF  y CADH 

COMMON  CADS  y CAEAF  y CAHSAF  y CAHSTS  y CAl P 

COMMON  CAR3FC  y CASF  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y FA VG ( 5 ) y PFSTSP  y PFAC  y RCLTEC ( 29  y 34 ) 

COMMON  TCARC5) yTHICK(lO) y THKTS y TTL ( 40 ) 

INT  EGER  EXI T y CLMA  y GDES  y GWHY  y OVBD  y SBSL 
INTEGER  SCECy SWHYy TPSLy VGTAy ANIM 
INTEGER  CL I MAT  y GENDES  y 6RWHYD  y OVRBDN 
INTEGER  SOCECN y SUBSOI ySURHYDyTOPSOI 
INTEGER  VEGETA y ANIMAL 

INTEGER  RCLIMA  y RGENDE  y RGRWHY  y ROVRBD  y RSOCEC 
1 N I EGER  RSUBSO  y RSURHY  y RTOPSO  y RVEGET  y RANI MA 
INTEGER  RCLTEC y TTL 


INTEGER  COMMON  (1) 


0100 

EQUIVALENCE 

(COMMON 

(1) 

y ITEK 

0101 

EQUIVALENCE 

(lARRY 

(1)  y 

LUT  ) 

0102 

EQUIVALENCE 

(IARY2 

(1)  y 

ISTRK) 

0103 

EQUIVALENCE 

(IARY2 

(2)  y 

ISECT) 

0104 

EQUIVALENCE 

(IARY2 

(3)  y 

I CODE) 

0105 

EQUIVALENCE 

(IARY2 

(4)  y 

LEN) 

(1)  ) 


LOGICAL  LER 


DIMENSION  VOL  <10)y 


CST 


(10)y  ITCA  <6) 
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0111 

0112 

0113 

0114 

0115 

0116 

0117 

0118 

0119 

0120 

0121 

0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 

0161 

0162 

0163 

0164 

0165 

0166 


C 

C 

C GET  GRADING  PARAMETERS  AND  LOGICAL  UNIT 

C 

LUD  = lARRY  (3) 

AREA  (LUO)  = 0* 

GCPA  (LUO)  = 0* 

CALL  rSOCA  (ODLy  CS7 , TOTOOL?  TOTCST) 

C 

C SET  HEIGHT  OF  UPPER  TABLE  AND  REPOSITION 

C 


IHGT 

= 20 

NHBP 

(LUO)  + 15 

CALL 

MOOAB 

( lOy 

565  ) 

FILL 

THE  TABLE  COMMAND  ARRAY 

ITCA 

(6)  == 

60 

ITCA 

11 

ITCA 

(6)  + 210 

ITCA 

(4)  = 

ITCA 

(5)  + 200 

ITCA 

(3)  = 

ITCA 

(4)  T 110 

ITCA 

(2)  = 

ITCA 

(3)  -f  125 

ITCA 

(1)  = 

ITCA 

(2)  + 150 

DRAW 

THE  TABLE 

CALL 

DRWAB 

( lOOOy  565  ) 

CALL 

MOOAB 

( lOOOy  515  ) 

CALL 

DRWAB 

( lOy 

515  ) 

CALL 

MOOAB 

( lOy 

515  - IHGT  ) 

CALL 

DRWAB 

( lOOOy  515  - IHGT 

DO  100  I = 2y  6f  2 

CALL  MOOAD  ( ITCA  (I-l)y  515  - IHGT  ) 

CALL  DRWAB  ( ITCA  (I-l)y  565  ) 

CALL  MOOAB  ( ITCA  (I)y  565  ) 

100  CALL  DRWAB  ( ITCA  (I)y  515  - IHGT  ) 

C 

C WRITE  IN  THE  TEXT 

C 


CALL  MOOAB  ( lOy  565  ) 

CALL  ANMOD 

WRITE  ( LUDy'  1010  ) 

1010  F0RHAT(/"H/B‘2X-HU  SLOPES-DEG - 2X " BENCHES  (FT)“2Xy 
+ 'HU  HGT-2X'BEN  LEN“2X'00L  GRADED  V 
■f ‘NO*  • 2X • INI TI AL : F INAL  “ 2X‘ INI TIALJF INAL '■  2Xy 
+• (FEET) ‘3X‘ (FEET) ‘3X‘ (CU  YDS) ‘4X‘C0ST" ) 


CALL  MOVAB  (Oy  496) 

CALL  ANMOD 

DO  110  I = ly  NHBP  (LUO) 

110  WRITE  (LUDy  1020)  ly  HWSLI  (LUOy  I)y  HWSLF  (LUOy  l)y 

> BENWI  (LUOy  I)y  BENWF  (LUOy  I)y 

> HWHT  (LUOy  I)y  BENLEN  (LUOy  I)y 

> OOL  ( I ) y CST  ( I ) 

1020  FORMAT  ( IX y 12 y 2X y F7 * 1 ‘ F6 ♦ 1 y F7 * 1 ‘ F 6 * 1 y F7 * 1 y 
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0167 

0168 

0169 

0170 

0171 

0172 

0173 

0174 

0175 

0176 

0177 

0178 

0179 

0180 

0181 

0182 

0183 

0184 

0185 

0186 

0187 

0188 


WRITE  <LUl'iyl030)  TOTOOLy  TOTCST 
1030  FORMAT ( /42X  * TOTALS : " F 1 0 ♦ 1 y F 1 3 ♦ 2 ) 

REHtOT  = REHOOL  (LUO)  t REHCPY  (LUO)  / 100. 

WRITE  (LUDy  1040)  REHOOL  (LUO)y  REHCPY  (LUO)y  REHTOT 
1040  FORMAT  (/y 2X " REHANDLE  VOLUME  J‘F13.2-  CUBIC  YARDS"/y 

> 2X"REHANDLE  COST  :‘F13.2*  CENTS  PER  CUBIC  YARBVy 

> 2X* REHANDLE  TOTAL  :^F13.2-  DOLLARS*) 

REHTOT  = REHTOT  / AREA  (LUO) 

WRITE  (LUDy  1050)  AREA  (LUO)y  REHTOTy  GCPA  (LUO) 

1050  FORMAT  (/y2X"AREA  COVERED  BY  GRADED  SPOILS  J*F13.2‘  ACRES'/y 

> 2X'REHANDLE  COST  PER  ACRE  :-F13.2"  DOLLARS*/y 

> 2X'GRADING  COST  PER  ACRE  :‘F13.2*  DOLLARS*) 

GCPA  (LUO)  = GCPA  (LUO)  T REHTOT 

WRITE  (LUDy  1060)  GCPA  (LUO) 

1060  FORMAT  (2X*  ttttt  GRAND  TOTAL  COST  PER  ACRE  IS  "F13.2*  DOLLARS* IX 


C 

C 


C 


END$ 


RETURN 


END 
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0001 

0002 

0003 

0004 

0005 

0006 
0007 
0003 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 
0017 
0013 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 
0043 

0049 

0050 

0051 

0052 

0053 

0054 


C 

C 

G 

C 

C 

C 

C 


C 

C 

C 

C 

c 


c 

G 

G 

C 

C 

G 

C 

G 


C 

G 

C 

C 

G 


G 


G 


G 

G 

C 

G 


G 

C 

C 

C 

G 

G 


C 

G 


G 

C 

G 

G 


G 

G 


C 

G 

G 

C 


TN4 

SUBROUTINE  TSOCA  ( OOL y GST y TGTOGL y TOTCSf ) 
TRuGK  AND  SHGOEL  : VGLUMESy  COST y AND  AREA 

LEOEL  5 


OGLUhE  AND  COST  ARRAYS  EGR  GRADING  THE  HIGHWALLS  y AS  HELL  AS 
TOTAL  OGLUME  GRADED  AND  TOTAL  GOST  OF  GRADING  ARE 


GOiiPUTED  FOR  EITHER  SENI-GIRGULAR  OR 
IN  ADDlTIONy  FINAL  GRADED  AREA  COOERED 
PERCENT  OF  THE  FINAL  GRADED  AREA  EQUAL 


RECTANGULAR  SHAPED  SPOIILS. 
BY  THE 
TO  NINETEEN 


SPOILSy 


AND  THE 
DEGREES 


ARE  DETERMINED^ 


TSOCA  IS  ACCESSED  BY  T 


TCOT 

owl 


AND 


ISSTP 


THE  GALLING  SEQUENCE  IS  t 


CALL  TSOCA  <OOLy  GSTy  TOTOOLy  TOTCST) 


OJHERE  : 

OOL  ->  OOLUMES  GRADED  ON  HIGHUALLS 
GST  •“>  COSTS  OF  GRADING  HIGHWALLS 
TOTOOL  ->  TOTAL  OOLUME  GRADED 
TOTCST  -•>  TOTAL  COST  OF  GRADING 


LOCAL  variables: 

ADOQ  “>  ANGLES  DEFINED  BY  BENCH  LENGTHS 
AMPC  “>  BASE  AREAS  OF  LOWER  HIGHWALLS 
GP  ->  INNER  ARC  LENGTHS  (FINAL) 

LS  ->  INNER  ARC  LENGTHS  (INITIAL) 

OC  ~>  INNER  RADII  OF  HIGHWALL/BENCH  PAIRS  (FINAL) 

OL  ->  INNER  RADII  OF  HIGHWALL/BENCH  PAIRS  (INITIAL) 

AB  ->  LOWER  HIGHWALL  WIDTH  INCREASES  DUE  TO  GRADING 
AM  ~>  OUTER  ARC  LENGTHS  (FINAL) 

BN  ->  OUTER  ARC  LENGTHS  (INITIAL) 

OA  ~>  OUTER  RADII  OF  HIGHWALL/BENCH  PAIRS  (FINAL) 

OB  ->  OUTER  RADII  OF  HIGHWALL/BENCH  PAIRS  (INITIAL) 

OD  ->  RADII  OF  BENCHES  ALONG  THE  OUTSIDE  EDGE 
VOLS  ->  VOLUMES  TO  BE  SUBTRACTED 
AE  “>  CROSS-SECTIONAL  WIDTHS  OF  FINAL  HIGHWALLS 
BD  ->  GROSS  - SECTION  WIDTHS  OF  INITIAL  HIGHWALLS 

THIS  ROUTINE  WAS  WRITTEN  BY  GREEN 

CLAIM  RELEASE  1.0  - APRIL  ly  1980 


TEKTRONIX  COMMON 


COMMON  ITEK  (45) 

G 
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COMMON  lARRY(^) » IARY2<5) ^LERyLUFyLUL 


0050  C 

0056 

0057  C 

0058  C 

0059  C 

0060 
0061 
0062 

0063 

0064 

0065 

0066  C 

0067  C 
006S  C 

0069 

0070 

0071 

0072  C 

0073  C 

0074  C 

0075 

0076 

0077 

0078  C 

0079  C 

0080  C 

0081 
0082 

0083 

0084  C 

0085  C 

0086  C 

0087 

0088 

0089 

0090  C 

0091  C 

0092  C 

0093 

0094 

0095 

0096 

0097 

0098 

0099  C 

0100 
0101 
0102 

0103 

0104 

0105 

0106 

0107 

0108  C 

0109 


P01N1ER8 


COMMON  EXIT  y I ANM  ( 3 ) y 1 CL  I < 2 ) y I GEN  ( 3 ) y I GRl-J  ( 5 ) 

COMMON  IGPTN  y lOOR ( 7 ) y IHB  . y I SDC ( 6 ) y I SUB ( 8 ) 
COMMON  j;SUR(6)  y 1TDP<9)  y I0EG<2)  yLEXIT  yLUO 

COMMON  MODE  y NANM  yMCLl  yNGEN  yNGRW 

COMMON  NOVi;-  yNSECTS  y NSGC  yNSUB  yNSUR 

c 0 ? 1 M 0 a T 0 r-'  y n u y o e g 

GRADING  PARAMETERS 


COMMON  AREA ( 5 ) y BENLEN ( 5 y 1 0 ) y BENy I < 5 y 10 ) y COGO  y GCPA  < 5 ) 
COMMON  Spec ( 5 ) y HWHT ( 5 y 1 0 ) y HWGL I v 5 y 1 0 ) y NHBP ( 5 ) y PCEQ 1 9 ( 4 ) 
COMMON  BENWF(5y 10) ?REHCPY(5) yREH00L(5) yHWSLF(5y 10) yUSR 


CATEGORY  TEXT 

COMMON  AN  I M ( 23  y 1 3 ) y Cl..  MA  ( 1 3 y 1 3 ) y GBES  < 1 5 y 1 3 ) y Oyi  lY  < 22  y 1 3 ) 
COMMON  OUBDdl  y 13)  ySBSL(  13)  y SCEC(33y  13)  y BOHY  ( 44  y 1 3 ) 

COMMON  rPGL(49y 13) y OGTA( 15y 13) 

EXPECTATION  OALUEG 

COMMON  AN  I MAE  ( 1 3 y 6 ) y Ct„  1 MAT  < 8 y 6 ) y GENDEB  < 8 y 6 ) y GRWH YD  ( 1 9 y 6 ) 
COMMON  OORBDN ( 28  y 6 ) y SOCECN ( 29  y 6 ) y BUBSOl ( 30  y 6 ) y BURN YD  < 23  y 6 ) 
COMMON  TOPSO I ( 33  y 6 ) y OEGETA ( 1 0 y 6 ) 

CATEGORY  RESPONSES 

COMMON  RANIMA(3) yRCLIMA(2) yRGENDE<3) yRGRWHY(5) 

COMMON  R00RBD(7y 10) yRS0CEC(6) yRSUDSO(B) yRSURHY(6) 

COMMON  RT0PS0(9) yROEGEI (2) 

FEASl y TECONyOPUSE  SUBSYSTEM  PARAMETERS 

COMMON  CAAHMyCABAHyCABFN(3) yCADFP<3) yCABHM 

COMMON  CABS ( 2 ) y CAC  y CACP  y CABF  y CADH 

COMMON  CADS  y CAEAP  y CAHSAP  y CAHSTS  y CAIP 

COMMON  CAR3FC  y CASE  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y PAOG ( 5 ) y PFSTSP  y PFAC  y RCLTEC ( 29  y 34 ) 

COMMON  TCAR ( 5 ) y THICK ( 10 ) y THKTS  y TI L < 40 ) 

I NTEGER  EXI T y CLMAy  ODES  y GUHY  y OOBD  y SDSL 
INTEGER  SCEC  y SWHY  y TPSL  y MGTA  y ANIM 
INI  EGER  CLIMAT  y GENDES  y GRWHYD  y GVRBDN 
INTEGER  SOCECN y SUBSOI ySURHYDy  TOPGGI 
I N I L G E:  R 0 E G E T A y A N I r i A L 

INTEGER  RCL IMA  y RGENDE  y RGRWHY  y ROORBD  y RSOCEC 
INTEGER  RSUDSO  y RSURHY  y RI OPSO  y RVEGET  y RANI MA 
INTEGER  RCLTEC yTTL 

INTEGER  COrEiOM  (1) 


0110 


L..  K '1 1.1  V r i L-  L.,  I i 0/  L..  \ «...  I*  4 » i I •:  >. 


1 'I  L 


( 1 
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0111 

EQUIOALENCE 

(lARRY 

(l)y  LUT) 

0112 

EGUIOALENCE 

(IARY2 

(l)y  ISTRK) 

0113 

EQUIVALENCE 

(IARY2 

(2)y  ISECT) 

0114 

EQUIVALENCE 

(IARY2 

(3)y  ICODE) 

0115 

EQUIVALENCE 

(IARY2 

(4)y  LEN) 

0116 

C 

0117 

LOGICAL  LER 

, 

0118 

C 

0119 

c 

0120 

DIMENSION 

DD(IO) y 

AE(10)y  AD  (10) y 

0121 

0D( 10) y 

GL(10)y  0D(10)y 

0122 

ADOQC 10) 

y DN(iO)y  LS(10)y 

0123 

AMPC(iO) 

y 0A(10)y  0C(10)y 

0124 

AM ( 1 0 ) y 

CP(10)y  VOL  (10) y 

0125 
0 1 *•-'  o> 
Ox  ^ / 


0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 

0158 

0159 

0160 
0161 
0162 

0163 

0164 

0165 
^ 


c 

c 

c 

c 


c 

c 


'v'GLB(lO)  » 
AGBD(IO) y 
GDC  10) 


CST  (10)y  DL<10)y 
AHAD  (lOyDGClOy 


0120 

C 

f-'r  1 O O 

REAL  LS 

0130 

c 

0131 

c 

CONVERT  COMMON  VARIABLES  ' 

0132 

c 

PROGRAMMERS  MANUEL 

0133 

c 

0134 

DO  5 I = ly  10 

0135 

DL  (I)  DENWI  (LUOy  I) 

0136 

GD  (I)  = HWHKLUOy  I) 

0137 

AGED  (1)  HWSLI  (LUOy  I) 

0130 

AHAD  (I)  HWSLF  (LUOy  I) 

0139 

5 DQ  (I)  ==  DENLEN  (LUOy  I) 

0140 

c 

0141 

c 

PRELIMINARY  INFORMAT  ION  ** 

1.)  X-GECTIONAL  GIDTHS  OF  INITIAL  HIGHWALLS 

2*)  X-SLCTIGNAL  WIDTHB  OF  FINAL  HIGHNALLB 

3*)  LOUER  H1GH8ALL  WIDTH  INCREASES  DUE  TO  GRADING 

TOTOOL  =0* 

TOTCST  = 0* 

AREA  (LUO)  = 0, 

GCPA  (LUO)  = 0* 

DO  10  1 = ly  NHBP  CLUO) 

DD  (I)  =••  GD  CD  / TAN  CAGBD  CD  % *01745) 

AE  (I)  = GD  (1)  / TAN  (AHAD  (I)  t .01745) 


10  AD  CD 


/AT** 

V MC. 


(I) 


CD)  / 


GOTO  <30y  20)  IFIX  (SPCC  (LUO)) 


DETERMINE  AREA  COHERED  DY  GRADED  (RECTANGULAR)  SPOIL 

20  AREA  (LUG)  ( ED  ( 1 ) i DL  ( 1 ) i AD  ( 1 ) ) 

> t (DO  (D) 

DO  25  I 2y  NHBP  (LUO) 

25  AREA  (LUO)  = AREA  (LUO)  T (DD  (1)  i DL  (1)) 

> t (DO  (I)) 

GOTO  90 


C 


Vj  !.T  T <:  ? a t ^ f i"'  .>■  !.:<  r ' i''  r> ' > < " f'  ti  t<  r-  s > ■*  r.  ? ,•  < ' r • ■ t • •<  i > i • i i f ^ 
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0167 

0168 

0169 

0170 

0171 

0172 

0173 

0174 

0175 

0176 

0177 
0173 
0179 

0130 

0131 

0132 

0133 
0184 
0135 
0 1 86 
0137 
0188 
0139 

0190 

0191 

0192 

0193 

0194 

0195 

0196 

0197 

0198 

0199 

0200 
0201 
0202 

0203 

0204 

0205 

0206 
0207 
0203 

0209 

0210 
0211 
0212 

0213 

0214 

0215 

0216 
0217 
0213 
0219 


r'*  'I  • i 


C 

c 

c 

c 


c 

c 

c 


c 

c 

c 

c 


c 

c 

c 


c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


outl;i;:  and  inner  radius  or  iiighuall/bench  pair  t i 


30  OB  (1)  = 
BO  35  I = 
35  OB  (1)  =- 
OL  (1)  = 


AB  (1) 

= ly  NHBP  (LUO) 

OB  (1)  1-  BB  (I)  f BL  (I) 
OB  (1)  ~ BB  <1)  - BL  (1) 


AB  (1) 


OUTER  AND  INNER  RADIUS  OF-  HIOIIWALL  / BENCH  PAIR  “I 


BO  40  I 2y  NHBP  (LUO) 
OB  (1)  CL  (I  1) 

40  OL  (I)  ---=  OB  (I)  - BB  (I) 


BL  (I) 


RADIUS  OF  BENCH  ‘I"  ALONG  OUTSIDE  EDGE?  ANGLE  DEFINED 
BY  THIS  BENCHy  AND  THE  OUTER  AND  INNER  ARC  LENGTHS 

BO  50  I ==  ly  NHBP  (LUO) 

OD  (I)  = UL  (1)  I BL  (I) 

ADCQ  ( I ) = BQ  ( I ) / DD  < I ) 

BN  (I)  ==  OB  (I)  t ADOQ  (1) 

50  LS  (I)  OL  (I)  t ADOQ  (1) 

F-INAL  AREA 

DO  60  I = ly  NHBP  (LUO) 

60  AREA  (LUO)  AREA  (LUO)  T (OB  (1)  t BN  (I) 

> --  OL  (1)  >F:  LS  (D)  / 2* 

CONCERT  AREA  F ROH  SQUARE  F“EET  TO  ACRES 

90  AREA  (LUO)  ==  AREA  (LUO)  / 43560. 


DETERMINE  COLUME  GRADED  AND  COST  FOR  GRADING 


FIRST y DETERMINE  BASE  AREAS  OF  LOWER  HIGHWALLS 


GOTO  (200y  100) 


IFIX  (Spec  (LUO)) 


RECTANGULAR  SPOILS 


100  BO  150  I 
150  AMPC  (I) 
GOTO  500 


ly  NHBP  (LUO) 

(AE  (I)  / 2.  ) DQ  (1) 


C 

C 


SEMI-CIRCULAR  SPOILS 


200  OA  ( 1 ) 
DC  (1) 


OB  (1) 
OA  (1) 


AE  (1)  / 2 


DO  210  1 ==  2y  NHBP  (LUO) 
OA  ( I ) =-  OB  ( I ) -^-  AB  ( I ) 


210  UC  O.  ) - OA  (I) 


Irl  iZ 


( i \ / '■> 

\ X / / 
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0223 

DO  220  I 

= 1,  NHDP  (LUO) 

0224 

Ah  (I) 

OA  (I)  t ADOQ  (I) 

0223 

CP  (1)  == 

OC  (1)  t ADOQ  (I) 

0226 

220 

AhPC  (I) 

==  (OA  (I)  AM  (I)  “ OC  (I)  )!<  CP 

0227 

C 

0228 

C 

DETERhINE 

VOLUME  INCREMENTS 

0229 

C 

0230 

500 

DO  505  I 

= ly  NHDP  (LUO) 

0231 

505 

VOL  (I)  == 

AHPC  (I)  GD  (1)  / 4. 

0232 

C 

0233 

C 

DETERhINE 

VOLUME  TO  BE  SUBTRACTED  FROM  TH: 

0234 

C 

0233 

IF  (IFIX 

(GPCC  (LUO))  .EQ*  1)  507 y 515 

0236 

c 

0237 

c 

SEhl-CIRCULAR  SPOILS 

0238 

c 

0239 

507 

OB  (1) 

OB  ( 1 ) - AB  ( 1 ) 

0240 

DO  510  I 

=•-.  ly  NHDP  (LUG) 

0241 

510 

VOLS  (I) 

(OB  (I)  BN  (I)  -■  OC  (I)  ^ CP 

0242 

t GD  (I)  / 4* 

0243 

00 TO  517 

0244 

c 

0245 

c 

RECTANGULAR  SPOILS 

0246 

c 

024  7 

515 

DO  516  1 

ly  NHBP  (LUO) 

0248 

516 

VOLS  (I) 

((ED  (1)  / 2.)  t DQ  (1)) 

0249 

t GD  (I)  / 4. 

0250 

c 

0251 

517 

DO  518  I 

=:  ly  NHDP  (LUO) 

0252 

518 

VOL  (I) 

(VOL  (I)  - VOLS  (D)  / 27. 

0253 

c 

(.^  2 5 4 

c 

DETERHINE 

COST  INCREMENTS 

0255 

c 

0256 

DO  520  I 

==  ly  NHBP  (LUO) 

0257 

CST  (I)  = 

VOL  (1)  t COGO  / 100. 

0258 

TOTVOL  - 

TOTVOL  + VOL  (I) 

0259 

520 

TOTCST  = 

TOTCST  + CST  (I) 

0260 

0261 


0271 

0272 
76 


GCF'A  (LUO) 


TOTCST  / AREA  (LUO) 


C 


0262 

C DETERMINE  PERCENT  OF  FINAL 

ARE 

EQUAL  TO 

19 

DEGREES 

0263 

0264 

C 

IF  (LUO  .EQ. 

1)  RETURN 

0265 

PCEQ19  (LUO  - 

1)  = 0. 

0266 

DO  530  I ==  ly 

NHBP  (LUO) 

0267 

IF  (AH AD  (I) 

♦LT.  19)  GOTO 

530 

0268 

PCEQ19  (LUO  - 

1)  ==  PCEQ19 

(LUO 

- 1)  T 2. 

AM PC  ( I ) 

0269 

530  CONTINUE 

0270 

PCEQ19  (LUO  -• 

1)  = PCEQ19 

(LUO 

-•  1)  / AR 

EA 

(LUO) 

RETURN 


02“? 


ENi;i$ 
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;&TSXBA  T=--:00004  IS  ON  Cl\‘00015  USING  00038  BLKS  K-0000 


0001 

0002 

0003 

0004 


0034 

0035 

0036 

0037 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045 

0046 

0047 
0043 

0049 

0050 

0051 

0052 

0053 


nN4 

c 

c 


SUBFs’OUllNE  TSXBA 

TRUCK  AND  SHOORL  t CROSS-SECTION  OF  BENCH  ABJUSTMENT 


SECTIONAL  OIEW  OF  BENCH 


0005 

C 

LEOEL  4 

0006 

C 

0007 

C 

THIS 

ROUTINE  BISPLA 

0008 

C 

ADJUS 

TMENTS  NEEDED 

0009 

C 

0010 

C 

TSXBA  IS 

ACCESSED  BY  TS 

0011 

C 

0012 

C 

THE  CALLING  SEQUENCE  IS 

0013 

c 

0014 

c 

SUBRGUTIN 

ES  SCHEDULED t 

0015 

c 

0016 

c 

AN  MOB 

(TCS) 

0017 

c 

DASHA 

(TCS) 

0018 

c 

i.1  i(  A W A 

(TCS) 

0019 

c 

BRWRL 

(TCS) 

0020 

c 

MOOAB 

(TCS) 

0021 

c 

MOVE  A 

(TCS) 

0022 

c 

MOMRL 

(TCS) 

0023 

c 

SWNDU 

(TCS) 

0024 

c 

OWNDO 

(TCS) 

0025 

c 

BON 

(CLAIM) 

0026 

c 

TSBLA 

(CLAIM) 

0027 

c 

rSBBR 

(CLAIM) 

0028 

c 

0029 

c 

LOCAL  OARIABLES: 

0030 

c 

0031 

c 

ABWBA 

~>  ADJUSTED 

0032 

c 

ABWBB 

“>  ADJUSTED 

0033 

c 

BMIN 

->  MINIMUM 

C 

C CBTR 

C IANS  - 

C IOC  ••• 

C ISC  - 

C NDP  - 

C XEXT 

C XSWFH 

C XSWIH 

C 

C THIS  ROUTINE  WAS  WRITTEN  BY  GREEN 
C 


THE  USER'S  SLOPE  REQUEST 
->  CONOERSION  J DEGREES  TG  RADIANS 
ANSWER  CELL 

ORIENTATION  CODE  (SEE  DON) 

SIZE  CODE  (SEE  DON) 

NUHBER  OF  DEC I HAL  PLACES  (SEE  BON) 

->  X EXTENT 

->  CROSS  - SECTIONAL  WIDTH  OF  FINAL  HIGHWALL 
->  CROSS  - SECTIONAL  WIDTH  OF  INITIAL  HIGHWALL 


C %■  'V^-  n-  h-  T 'I'  CLAIM  RELEA  S E 1*0 

C 

c 

C TEKTRONIX  COMMON 

C 

COMMON  ITEK  (45) 

C LOGICAL  UNITS  AND  COMMON  LOCATION 
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005‘5  C 
00^:i6 
COS/  C 

0058  C 

0059  C 

0060 
0061 
0062 

0063 

0064 

0065 

0066  C 

0067  C 

0068  C 

0069 

0070 

0071 

0072  C 

0073  C 

0074  C 

0075 

0076 

0077 

0078  C 

0079  C 

0080  C 

0081 
0082 

0083 

0084  C 

0085  C 

0086  C 

0087 

0088 

0089 

0090  C 

0091  C 

0092  C 

0093 

0094 

0095 

0096 

0097 

0098 

0099  C 

0100 
0101 
0 .1 0 2 

0103 

0104 

0105 

0106 

0107 

0108  8 

0109 

0110 


CDHMON  IARRY<5) ? IARY2(5) ? LLR y LUF » LUL 


POINTERS 


COmOH  EXIT  y 1ANN(3)  y ICLI  (2)  y IGEN<3)  y IGRW(5) 
COHNGN  IGPTN  y iOOR ( 7 ) y II  (B  yIS0C(6) y ISUB(8) 

COMMON  1GUR(6) y IT0P<9) y I0EG(2) yLEXIT  y LUO 
COMMON  MODE  yNANM  yNCLI  tNGEN  yNGRW 

COMMON  NOOR  yNSECTS  y NSDC  yNSUB  yNSUR 

COMMON  NTOP  yNU  yNOEG 


GRADING  PARAMETERS 


COMMON  AREA  (5)  y BENLEN ( 5 y 1 0 ) yBENUKSy  10)  y COGG y GCPA < 5 ) 
COMMON  SPCC(5) yHUHT(5y 10) y HUSLI (5y 10) yNHBP(5) y PCE019(4 ) 
COMMON  DENUF<5y 10) yREHCPY<5) yREH00L<5) yHWSLF(5y 10) y USR 


CATEGORY  TEXT 


COMMON 

COMMON 

COMMON 


ANIM<23y 13) y CLMA( 13y 13) yGDES( 15? 13) y6UHY(22y 13) 
OVBDCll y 13) ySBSL(13) y SCEC < 33 y 1 3 ) y SONY ( 44 y 1 3 ) 
TPSL(49y 13) yOGTAC 15y 13) 


EXPECTATION  VALUES 

COMMON  AN I MAE  < 1 3 y 6 ) y CL I MAT  < 8 y 6 ) ? GENDES  < 8 y 6 ) y GRWH YD ( 1 9 y 6 ) 
COMMON  OVRBDN ( 28  y 6 ) y SOCECN ( 29  y 6 ) y SUBSOI ( 30  y 6 ) y SURH YD ( 23  ? 6 ) 
COMMON  T0PS0I(33y6) y VEGETA ( 10 y 6 ) 

CATEGORY  RESPONSES 

COMMON  RANIMA(3) yRCLIMA(2) y R6ENDE ( 3 ) y RGRWHY < 5 ) 

COMMON  R0VRBD(7y 10) yRS0CEC(6) y RSUBSO ( 8 ) y RSURHY < 6 ) 

COMMON  RT0PS0(9) y RVEGET<2) 


FEASlyTECONyOPUSE  SUBSYSTEM  PARAMETERS 


COMMON  CAAHMyCABAHyCABFN<3) yCABFP(3) yCABHH 

COMMON  CABS ( 2 ) y CAC  y CACP  y CADF  y CADH 

COMMON  CADS  y CAEAF  y CAHSAF  y CAHSTS  y CAIP 

COMMON  CAR3FC  y CASF  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y FAVG ( 5 ) y PFSTSP  y PFAC  y RCLTEC ( 29  y 34 ) 

COMMON  TCAR  < 5 ) y THICK (10 ) y THKT  S y TTL ( 40 ) 


INI  EGER 
INTEGER 
INTEGER 
INTEGER 
INTEGER 
INTEGER 
INTEGER 
INTEGER 


EXIT?  CLMA  y GDES  y GUHY  ? OVBD  y SBSL 
SCEC  y SWH  Y y TPSL  y VGTA  y ANIM 
CL 1 MAT  y GEMDEG?  GRUHYDy  OVRBDN 
SOCECN y SUBSOI ? SURHYD y TOPSOI 
VEGETA? ANIMAL 

RCL I MA  y RGENDE  y RGRUHY  y ROVRBD  y RSOCEC 
RSUBSO  y RSURHY  y RTOPSO  y RVEGET  y RANIMA 
RCLTEC y TTL 


INTEGER  COMMON  (1) 
EUUiVALENCL  (COMfiON  (l)y 


I I LK 


1 ) ) 
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0111 

0112 

0113 

011‘1 

0115 

0116 
0 1 1 7 
Oils 

0119 

0120 
0121 
0122 

0123 

0124 

0125 

0126 

0127 

0128 

0129 

0130 

0131 

0132 

0133 

0134 

0135 

0136 

0137 

0138 

0139 

0140 

0141 

0142 

0143 

0144 

0145 

0146 

0147 

0148 

0149 

0150 

0151 

0152 

0153 

0154 

0155 

0156 

0157 
0153 

0159 

0160 
0161 
0162 
0163 
01  64 
0165 
01  66 


EQUIVALENCE 

( XARRY 

(1)  y 

LUT  ) 

EQUIVALENCE 

(IARY2 

( 1 ) y 

XSTRK) 

EQUIVALENCE 

(1ARY2 

(2)  y 

ISECT) 

EQUIVALENCE 

( IARY2 

(3)  y 

I CODE) 

EQUIVALENCE 

(IARY2 

(4)  y 

LEN) 

C 

LOGICAL  LER 
C 
C 

0 INITIALIZE  LOCAL  VARIABLES 

C 

CDTR  = 0*01745 
ISC  =:  4 
NBF-'  2 
C 

C WRITE  THE  TITLE 

C 

CALL  AOVAB  ( 550^730) 

CALL  ANHOB 
WRITE  (LUTy  1000) 


C BETERMINE  THE  MIHIHUM  BENCH  WIDTH  THAT  WILL  ACCOMODATE  USR 


CALL  TSDDR  (HWHT  (LUOy  IHB)>  HWSLI  (LUOylHB)y  USRy  BMIN) 


C ADJUST  THE  BENCFIES  LESS  THAN  BMIN 

C 

BMIN  = BMIN  -}•  *01 
ABWBA  BENWI  (LUOy  IHB) 

IF  (BMIN  ♦6T*  BENWI  (LUOy  IHB))  ABWBA  = BMIN 
IF  (IHB  ♦EO*  1)  ABWBB  = ABWBA 
IF  (IHB  *GT*  1)  ABWBB  = BENWF  (LUOy  IHB  - 1) 
IF  (BMIN  *GT*  ABWBB)  ABWBB  BMIN 


C SET  THE  WINDOWS 


100 


C 

C 

C 


XSWFH  = HWHT  (LUO?  IHB)  / TAN  (USR  t CDTR) 

XSWIH  = HWHT  (LUOy  IHB)  / TAN  (HWSLI  (LUOy  IHB)  t CDTR) 

XLXT  ==  ABWBA  T ABWBB  4 XSWIH 

CALL  VWNDO  (0*y  XLXTy  0*y  XLXT  / 5*) 

IF  (HWHT  (LUOy  IHB)  *GT*  XLXT  / 5*) 

CALL  VWNDO  (0*y  XLXT?  0*y  HWHT  (LUOy  IHB)) 

DRAW  THE  X-SECTION 


CALL  SWNDO  (550y  440?  500?  220) 

CALL  MOMLA  (0*y  0*) 

IF  (IHB  *LQ*  1)  CALL  DASHA  (ABWBB  - 
IF  (IHB  *GT*  1)  CALL  DASHA  (ABWBB  ~ 


CALL 

DRAWA 

(XLXT 

- BENWI  (LUO? 

IHB) 

CALL 

DRAW  A 

< XExr 

- BENWI  (LUOy 

IHB)  y 

CALL 

Li  H hA  W A 

(XEXTy 

HWHT  (LUOy  IHB)) 

CALL 

DASHA 

(XEXTy 

0*y  54) 

CALL 

DASHA 

(ABWBB 

7 0 <•  y 5 4 ) 

CALL 

MOVEA 

(XLXT 

-•  ABWBA  - XSWI 

Hy  0* 

CAL.L.. 

DASHA 

(XLXT 

ABWBA?  F1WHT 

(LUO? 

BENWI  (LUOy 
BENWF  (LUO? 

~ XSWIH?  0*) 
HWHT  (LUO? 


IHB)y  54) 


IHB)  y 0<  y 
IHB  - l)y 


IHB)  ) 


I 


V ? 

0 4 y 


;4 ) 
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0167 

CALL  DASHA  (XLXT  ~ DENWI  (LUO?  I HD)  , HWHT  (LUO?  I HD) 

0168 

C 

0169 

IF  (ADUDA  ♦GT*  ABUDB)  110?  120 

0170 

c 

0171 

110 

CALL  MOUEA  (0*?  0*) 

0172 

CALL  DASHA  (XSUFH?  HWHT  (LUC?  IHB)?  54) 

0173 

CALL  HOULA  (0*y  0»)  , 

0174 

GOTO  150 

0175 

c 

0176 

120 

CALL  HOVLA  (XLXT?  HWHT  (LUO?  IHB)) 

0177 

CALL  DASHA  (XLXI  - XSWFH?  0*?  54) 

0178 

c 

0179 

c 

LABEL  THE  USEH^S  SLOPE  REQUEST 

0180 

c 

0181 

150 

CALL  hOORLdS?  0) 

0182 

CALL  DRWRL  (0?  30) 

0183 

IOC  =•“•  3 

0184 

CALL  DON  (USR?  ISC?  IOC?  NDP) 

0185 

CALL  MOORL  (-3?  0) 

0186 

CALL  DRWRL  (0?  3) 

0187 

CALL  DRWRL  (3?  0) 

0188 

CALL  DRWRL  (0?  ~3) 

0189 

CALL  DRWRL  (-3?  0) 

0190 

CALL  MOOEA  (0»?  0.) 

0191 

c 

0192 

c 

LABEL  LOWER  ADJUSTED  BENCH  (IF  NEEDED) 

0193 

c 

0194 

IF  (IHB  ♦EQ,  1)  GOTO  175 

0195 

IF  (ABWBB  <EQ*  BENWF  (LUO?  IHB  -1))  GOTO  175 

0196 

CALL  DRWRL  (-6?  --6) 

0197 

CALL  NOVRL  (6?  6) 

0198 

CALL  DRWRL  (6?  -6) 

0199 

CALL  NOURL  (~6?  6) 

0200 

CALL  DRWRL  (0?  --15) 

0201 

CALL  HOORL  (-10?  -10) 

0202 

CALL  ANNOD 

0203 

WRITE  (LUT?  1010)  ABWBD 

0204 

c 

0205 

c 

LABEL  UPPER  ADJUSTED  BENCH  (IF  NEEDED) 

0206 

c 

0207 

175 

IF  (ABWBA  .EQ*  BENWI  (LUO?  IHB))  GOTO  210 

0208 

CALL  MOUEA  (XEXT  - ABWBA  ? HWH7  (LUO?  IHB)) 

0209 

CALL  DRWRL  (6?  6) 

0210 

CALL  HOORL  (-6?  -6) 

0211 

CALL  DRWRL  (-6?  6) 

0212 

C A L_  L M 0 0 L ( 6 ? — 6 ) 

0213 

CALL  DRWRL  (0?  15) 

0214 

CALL  hOVRL  (-100?  30) 

0215 

CALL  ANNOD 

0216 

WRITE  (LUT?  1010)  ABWBA 

0217 

c 

0218 

c 

USER  OPTION  ->  USE  ADJUSTNENTS  ? 

0219 

c 

0220 

210 

CALL  MGVAB  (10?  200) 

0221 

C i i L L if  i I’T  i U 

0222 

WRITE  <LUi?  1020) 

!f;4) 
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0223  215  READ  (LUfyi^O  IANS 


0224 

0225 

0226 

0227 

0228 

0229 

0230 

0231 


IF-  (IANS  1 *AN1.U  IANS  .LE.  3)  GOTO  <220?  240?  230) 

WRITE  (LUTy  1025) 

GOTO  215 
G 

0 INCREASE  DENCF-{<S)  TO  SF’ECIF  I CATIONS 

0 

220  If-  (Spec  *EQ*  2»)  GOTO  225 
IF-  (LER)  CALL  ERASE 


0232  IF  (LER)  CALL  FFOME 

0233  IPTR  1 

0234  IF  (IF-ID  *EQ*  1)  GOTO  224 

0235  IPTR  2 

0236  BENCH2  BENUFI  (LUO?  IFU-;--!)  + ABWBD  - BENUF  (LUO?  1HB-~1 

0237  224  CALL  TSBLA  ( IPTR  ? IF-iB  ? ABWBA  ? BENCi-i2 ) 

0238  225  BENUI  (LUO?  IF-IB)  ==  ABUBA 

0239  BENUF  (LUO?  IHB)  ABUBA 

0240  IF  (IF-IB  *ECU  1)  RETURN 


0241 

BENWI  (LUO? 

IHB.  - 

- 1) 

BENWI 

(LUO? 

IHB  - 

1)  T ABWBB 

0242 

~ BENUF 

(LUO? 

IHB  - 

1 ) 

0243 

BENWE  (LUO? 

IHB  - 

- 1 ) 

===  ABWBB 

0244  RETURN 

0245  C 


0246  C EXIT  FRON  INPUT  NODE 

0247  C 

0243  230  IHB  ^ 0 

0249  240  RETURN 

0250  C 

0251  C FORHAT  STATEMENTS 

0252  C 

0253  1000  FORMAK "SUGGESTED  BENCH  AD JUSTMEN F ( S ) “ ) 

0254  C 

0255  1010  FORMAT  ("  INCREASE  TO  ■'F7*2*"") 

0256  C 


0257 

0258 

0259 

0260 
0261 
0262 

0263 

0264 

0265 

0266 

0267 

0268 


1020  FORMAT (5X" SUGGESTED  BENCH  INCREASES  FOR  GRADING'/ 
•I  5X“THIS  HIGHWALL  DOWN  TO  YOUR  SLOPE  OALUEV? 

-1-  5X'ARE  DISPLAYED  IN  THE  UPPER  RIGHT  CORNER* '// 

-f  5X'  YOU  may:*/ 

-I  5X“  1 “>  IMPLEMENT  THE  BENCH  INCREASES'/? 

-f  5X"  2 ->  RE  “ ENTER  THE  FINAL  SLOPE"/? 

-{-  5X"  3 ">  EXIT  FROM  THIS  ROUTINE'/? 

-i-  5X"  INPUT  ”>  _") 

C 

1025  FORMATC?  RE  ~ INPUT  ->  _"•) 

END 

EMD$ 
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STBXFS  T--=OOOOA  IS  ON  CROOOl^j  USING  00031  BLKS  R=0000 


0001 

FTN4 

0002 

SUBROUTINE  TSXFG 

0003 

n 

— 

“TRUCK  AND  SHOOEL  : X-SECTION  OF  FINAL  SLOPES 

0004 

c 

0005 

c 

LE05L  4 

0006 

c 

0007 

c 

THIS  i 

ROUIINE  DISPLAYS  A CROSS-SECTIONAL  VIEW  OF  THE  FINi 

0008 

c 

SLOPE 

oalue ♦ 

0009 

c 

0010 

c 

isxrs  IS  1 

ACCESSED  BY  TSIFG  AND  SWAPPED  IN  THROUGH  PROGRAM  T: 

0011 

c 

0012 

c 

THE  CALLING  SEQUENCE  IS  : CALL  TSXFG 

0013 

c 

0014 

c 

SUBRUUTIN! 

ES  SCHEDULED  ARE  : 

0015 

c 

001 6 

c 

ANHGD 

(TCS) 

0017 

c 

BELL 

(TCS) 

0018 

c 

DASHA 

(TCS) 

0019 

c 

Li  R A U A 

(TCS) 

0020 

c 

DRWRL 

(TCS) 

0021 

c 

ERASE 

(TCS) 

0022 

c 

HO'v'AE 

(TCS) 

0023 

c 

HO'v'EA 

(TCS) 

0024 

c 

HOORL 

(TCS) 

0025 

c 

SUN  DO 

(TCS) 

0026 

c 

TINPT 

(TCS) 

0027 

c 

OUNDO 

(TCS) 

0028 

c 

0029 

c 

IHE  LOCAL 

VARIABLES  ARE  : 

0030 

c 

0031 

c 

BENR 

~>  BENCH  REMOVED 

0032 

c 

CDTR 

->  CONVERSION!  DEGREES  TO  RADIANS 

0033 

c 

FTWBB 

-->  FINAL  TERRACE  WIDTH  OF  BENCH  BELOW 

0034 

c 

ICHAR 

~>  TINPT  CELL 

0035 

c 

IOC 

“>  ORIENTATION  CODE  (SEE  DVN) 

0036 

c 

ISC 

-->  SIZE  CODE  (SEE  DVN) 

0037 

c 

ITWBB 

->  INITIAL  TERRACE  WIDTH  OF  BENCH  BELOW 

0038 

r- 

u.* 

NDF‘ 

■"■>  NUMBER  OF  DECIMAL  PLACES  (SEE  DVN) 

0039 

c 

NLB 

~>  NUMBER  OF  LOWER  BENCH 

0040 

c 

XEXT 

->  X EXTENT 

0041 

c 

XSIaIFH 

->  CROSS-SECTIONAL  WIDTH  OF  FINAL  HIGHWALL 

0042 

c 

XSWIH 

->  CROSS-SECTIONAL  WIDTH  OF  INITIAL  HIGHWALL 

0043 

c 

o 

o 

c 

THIS  ROUTINE  HAS  WRITTEN  BY  GREEN 

004  5 

u 

0 0 4 6 

c 

•J-  J-  -.tA  .j.-  O/  ’O  * J-‘  *t’ 

a-  a*  ‘n'  'T*  -V  'V'  -Y-  4- 

t CLAIM  RELEASE  1*0  - APRIL  ly  1980 

0047 

c 

0048 

c 

!l 

{1 

t f 

It 

!i 

!l 

!! 

1! 

I! 

1! 

!1 

!i 

li 

!! 

!! 

!! 

II 

II 

!! 

II 

1! 

ii 

1! 

I! 

i! 

1! 

!! 

1! 

11 

i! 

!l 

II 

!! 

1! 

II 

1! 

it 

!! 

II 

II 

II 

i! 

11 

I! 

1! 

II 

1! 

II 

!!■ 

1! 

II 

11 

II 

II 

If 

il 

1! 

!! 

I! 

ii 

0049 

c 

0050 

c 

T E K f 0 in  X COHN  0 M 

0051 

c 

0052 

CCnHON  ITEK  (45) 

0 J s 

L- 

L'  ■ "i 
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0055  C 

0056 

0057  C 

0058  C 

0059  C 

0060 
0061 
0062 

0063 

0064 

0065 

0066  C 

0067  C 

0068  C 

0069 

0070 

0071 

0072  C 

0073  8 

0074  C 

0075 

0076 
007  2 

0078  C 

0079  C 

0080  C 

0081 
0082 

0083 

0084  C 

0085  C 

0086  C 

0087 
0083 

0089 

0090  C 

0091  C 

0092  C 

0093 

0094 

0095 

0096 

0097 

0098 

0099  C 

0100 
0101 
0102 

0103 

0104 
0 1 0 5 
0106 
0107 

01  OB  C 
0 i 0 S' 

0 J.  j 0 


COMMON  I ARRY  < 5 ) y I ARY2 ( 5 ) y LER  y LUF  y LUL 
PO INTERS 

COMMON  EXIT  y I ANM ( 3 > y I CL I < 2 ) y I GEN ( 3 ) y 1 GRW ( 5 ) 

COMMON  lOPTN  yI00R(7)yIHB  - y I BOC ( 6 ) y 1 SUB < 8 ) 

COMMON  I8UR(6) y I TOP (9) y 10EG<2) y LEX IT  yLUO 
COMMON  MODE  yNANM  yNCLI  yNGEN  yNGRW 

COMMON  NOOR  yNGECTG  yNSOC  yNSUB  y NSUR 

COMMON  NTOP  yNLi  yMVEG 

GRADING  PARAMETERS 

COMMON  AREA(5>  y BENLEN ( 5 y 10 ) yBENUI (5y 10) y COGO y GCPA < 5 ) 
COMMON  BPCC(5) yHUHTC5y 10) y HUSL I ( 5 y 1 0 ) yNHBP(5) yPCEQ19(4) 
COMMON  BENUF(5y 10) yREHCPY<5) yREH00L(5) yHWBLF(5y 10) yUSR 


CATEGORY  TEXT 

COMMON  ANIM(23y 13) yCLMA(13y 13) y6DES< 15y 13) yOUHY<22y 13) 
COMMON  G0BD<liyl3)ySBGL<:i3)y  SCEC  < 33  y 13 ) y SUHY  < 44  y 1 3 ) 
COMMON  TP3L(49y 13) yMGTA( 15y 13) 


EXPECTATION  VALUES 


COMMON  ANIMAL< 13y 6) y CL IMAT ( 8 y 6 ) y GENDES ( 8 y 6 ) y GRWHYB < 19 y 6 ) 
COMMON  0VRBBN(2By6) y GOCECN < 29 y 6 ) y 8UB80I < 30 y 6 ) y BURN YD < 23 y 6 ) 
COMMON  TOPSO I ( 33  y 6 ) y VEGETA ( 10  y 6 ) 


CATEGORY  RESPONSES 


COMMON  RAN I MA ( 3 ) y RCL 1 MA ( 2 ) y RGENDE  < 3 ) y RGRUH Y < 5 ) 
COMMON  R0VRBD(7y 10) y RSOCEC ( 6 ) y RSUBSO ( 8 ) yRSURHY<6) 
COMMON  RT  OPSO ( 9 ) y RVE6ET ( 2 ) 


FEASIyTECONyOPUSE  SUBSYSTEM  PARAMETERS 


COMMON  CAAHM  y CABAH  y CABFN ( 3 ) y CABFP ( 3 ) y CABHM 

COMMON  CABS  < 2 ) y C AC  y CACP  y CADF  y CADH 

COMMON  CADS  y CAEAF  y CAHSAF  y CAHSTS  y CAIP 

COMMON  CAR3FC  y CASF  y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y FAV6 ( 5 ) y PFSTSP  y PFAC  y RCLTEC ( 29  y 34 ) 

COMMON  TCAR(5) yTHIcK(lO) y THKTS y TT L < 40 ) 


INTEGER  EXIT?  CLMA  y GDES  y GWH Y y OVBD  y SDSL 
INT  EGER  SCEC  y SUM Y y T PSL  y VGTA  y ANIM 
I fT  [L  G E R C L ].  M A T 5 G E N D E S y G R ll  H Y D y 0 V R B D N 
INTEGER  SGCECNySUBSOl ySURRYDy  TGPBOI 
INTEGER  VEGETA y ANIMAL 

1 N TEGER  RCL I MA  y RGENDE  y RGRUH Y y RO VRBD  ? RSOCEC 
IN TEGER  RSUBSO  y RSURHY  ? RTOPSO  y RVEGET  y RANIMA 
INTEGER  RCLTEC yTTL 

INTEGER  COMMON  U) 

L L !.J  1 V r i 1 : X..  L L'i  iiTUf-l  ^ j.  y y 1 I Lf\  1 / 
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0111 

EQUIVALENCE  (lARRY  (1)?  LUT) 

0112 

EQUIVALENCE  (IARY2  (D?  ISTRK) 

0113 

EQUIVALENCE  (1ARY2  (2)?  ISECT) 

0114 

EQUIVALENCE  (1ARY2  (3)y  ICODE) 

0115 

EQUIVALENCE  (IARY2  (4)?  LEN) 

0116 

C 

0117 

LOGICAL  LER 

0 1 1 8 

REAL  IIWBB 

0119 

C 

0120 

C 

INITIALIZE  LOCAL  VARIABLES 

0121 

c 

0122 

CDTR  =••  0.01745 

0123 

ISC  - 4 

0124 

NBF-’  ==  2 

0125 

NLB  IHB  “ 1 

0126 

c 

0127 

c 

OJRITE  THE  TITLE 

0128 

c 

0129 

CALL  HOVAB  (550?  730) 

0130 

CALL  ANMOB 

0131 

WRITE  (LUT?  1000) 

0132 

0133 

0134 

0135 

0136 


0144 

0145 

0146 


C 

C 

c 


c 


SET  THE  WINDOWS 

CALL  TSDBR  (HWHT  (LUOy  IHB)?  HWSLI  (LUO»  IHB)? 
HWSLF  (LUOy  IHB)?  BENR) 


0137 

XSWIH  ==  HWHT 

(LUO?  IHB) 

/ TAN 

(HWSLI  (LUO? 

IHB)  ^ CDTR 

0138 

XSWEH  HWHT 

(LUO?  IHB) 

/ TAN 

(HWSLF  (LUO? 

IHB)  t CDTR 

0139 

IF  (IHB  .EQ. 

1)  ITWBB 

BENWI 

(LUO?  IHB) 

0140 

IF  (IHB  *GT. 

1)  ITWBB  == 

BENWF 

(LUO?  IHB  ~ 

1)  4-  BENR 

0141 

XEXT  =:  ITWBB 

■i-  XSWIH  -1 

BENWI 

(LUO?  IHB) 

0142 

IF  (IHB  .EQ. 

1)  FTWBB 

BENWF 

(LUO?  IHB) 

0143 

IF  (IHB  *6T. 

1)  FTWBB  = 

BENWF 

(LUO?  IHB  - 

1 ) 

CALL  OWNDO  (0*?  XEXT? 
IF-  (HWHT  (LUO?  IHB)  T 


20. j XEXT  / 5.) 

.GE.  XEXT  / 5. ) 


• V 

<■ 


0147 

.CALL 

VWNDO 

(0.?  XEXT?  -20.? 

HWHT  (LUO? 

IHB)  -F  30.) 

0148 

CALL 

SWNDO 

(550?  440?  500? 

220) 

0149 

c 

0150 

c 

DRAW 

INITIAL  DATA 

0151 

c 

0152 

CALL 

MOVEA 

( 0 . y 0 ♦ 

) 

0153 

CALL 

DASHA 

(ITWBB? 

0.?  54) 

0154 

CALL 

DASHA 

(ITWBB 

XSWIH? 

HWHT  (LUO? 

IHB)?  54) 

0155 

CALL 

DASHA 

(XEXT? 

HWHT  (LUO 

? IHB)?  54) 

0156 

CALL 

DASHA 

( XEXT  ? 

0 t 7 54 ) 

0157 

C A L L. 

DASHA 

(XEXT  - 

XSWIH  - 

BENWI  (LUO? 

IHB)?  0.?  54) 

0158 

c 

0159 

c 

DRAW 

FINAL 

DATA 

0160 

c 

0161 

CALL 

NOVEA 

( 0 ♦ ? 0 ♦ 

) 

0162 

CALL 

DRAWA 

(FTWBB? 

0.  ) 

0163 

CALL 

DRAW  A 

(FTWBB 

-}-  XSWI"  H ? 

HWHT  (LUO? 

IHB)  ) 

01  o4 

CALL 

DRAWA 

(XEXT? 

HWHT  (LUO 

7 IHB)) 

r t 

*-r  .1-  O.*  w* 

CALL 

1 i 0 V »;■_  'r  i 

(F 1 WBB? 

0 . ) 

V-  .1  c > o 

I* ' 

u.- 
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0137  C 

LABEL 

THE  1 

• INAL 

0130  C 

0139 

CALL 

MGORL 

( 13  y 

0170 

CALL 

BRURL 

(Oy 

0171 

ICC  == 

^ 3 

0172 

CALL 

DON  (HUSLF 

0173 

CALL 

HOORL 

( -3  y 

0174 

CALL 

BRURL 

( 0 y 

0173 

CALL- 

DR  URL 

(3y 

0 1 7 3 

CALL 

DRURL 

( 0 ? 

0177 

CALL 

DR  URL 

(-3y 

0178 

0179 

0180 
0181 
0182 
0183 
018^1 


0190 

0191 

0192 

0193 

0194 
0193 

j,  y 

0197 

0198 

0199 

0200 
0201 
0202 
0 A-.'1 0 3 
0204 

fS  •->  ,■->  cr 

V Al.  \/  U> 
n.  '"i  /%  I 

V ii.  x.'  O 

0207 

C\  /■',  ("I 

/ Ai.  •>.'  U> 

0209 

0210 

-!  H ■< 
1/  A-  J.  J. 

0212 

,•  \ « ■? 
A.,  jk  O 

0214 


•"»  4 t:* 

•%2  J. 

4.  ^ 

-(  -> 

4i-  X y 

4 r 'l 
\y .»:.  j. 

/ \ i •*> 

X y 


{.: 


8 


C 

C 

C 


C 

c 


SLOF’E  OALUE 
0) 


(LUGy 

0 ) 

3 ) 

0) 

-3) 

0) 


IHB)?  ISCs-  lOCy  NDF‘) 


LABEL  THE  INITIAL 


CALL  HOOEA  <XEXT 
CALL  MOORL  (13  s.  10) 

ICC  “ 1 

CALL  DON  (HWSLI  (LUG? 


SLOPE 

XBOilH 


BENWI  (LUOy  IHB)y  0*) 


IHB)y  IGC?  IGC?  NBP) 


0183 

CALL 

hOORL 

(3y 

0) 

0 1 8 3 

CALL 

DRURL 

(Oy 

3) 

0187 

CALL 

DRURL 

(3y 

0) 

0188 

CALL 

DRURL 

(Oy 

o 

0189 

CALL 

DRURL 

( - 3 y 

0 

LABEL  THE  TERRACEii; 


(I 


IF 
CALL 
CALL 
CALL 
CALL 
CALL 


HB 


♦ EQ 


nu  VL.  H 

BRHRL 

NGVRL 

BRHRL 

>.<nt  (r**( 

I 1 V I V L. 
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0042  COMMON  I ARRY ( 5 ) » I ARY2 ( 5 ) y LER . LUF y LUL 

0043  C 

0044  C POINTERS 

0043  C 

0046  COMMON  EXIT  y 1 ANn ( 3 ) y ICLI ( 2 ) y IGEN < 3 ) y IGRP ( 5 ) 

0047  COMMON  iOPTN  y I DOR ( 7 ) y I PNT R ?IS0C<6) ylSUB(B) 

0048  COMMON  ISUR ( 6 ) y I T CP ( ? ) y iOEG ( 2 ) y LEXIT  y LUO 

0049  COMMON  MODE  yNANM  yNCLI  yNGEN  yNGRW 

0030  COMMON  NOMR  yNSECTS  yNSOC  y NSUB  yMSUR 

0031  COMMON  NTOP  yNU  y NOEG 

0032  C 

0 j3w  c grading  parameters 

- V ! • 

W •/  < C.* 
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0000 

0006 

0007 

0008 

c 

0009 

r 

0060 

C 

0061 

0062 

0063 

0064 

C 

0060 

C 

0066 

C 

0 0 6 7 

0 0 6 8 

0069 

0070 

c 

0071 

c 

0072 

c 

0073 

00  74 

0070 

0076 

1**' 

Cv 

007  7 

c 

0078 

c 

0079 

0080 

0081 

0082 

0083 

0084 

0080 

c 

0086 

0087 

OOBS 

0089 

0090 

0091 

0092 

0093 

0094 

c 

0090 

0096 

0097 

0098 

0099 

0100 

0101 

0102 

c 

0103 

0104 

c 

0105 

c 

0106 

0107 

OIOS 

CGMHGN  AREA  (5)  :-BENLEM<^?  10)  ?BERWI(5?  10)  y COGO  ? GCPA  ( 5 ) 
COHMQN  GRD0BS(5)  ?HWHT(G?  10)  yHUSLKGy  10)  »NSPP(G)  H''CE{:U9(4) 
COMMON  PERCN  r<5s 10) yREHCPY(O) ? REHVOL < 0 ) y SLOPE ( 0 y 1 0 ) y OOP 


CATEGORY  TEXT 


COMMON  ANIM(23y  IS)  yCLMAdSy  13)  y GTE 
C G M M 0 N 0 0 T It  d 1 y j.  3 ) y S T l>  L ( 1 3 ) y S E C C 


3d0yl3)  yG0MY<22yl 
33y 13) ySWHY(44y 13) 


3) 


COMMON  TPSL(49y 13) yOGTA(15y 13) 


EXPECTAllON  OALUES 

COMMON  AN I MAL (1 3 y 6 ) y CL 1 MAT ( 8 y 6 ) y 6ENDES ( 8 y 6 X ^ GROH YD  d 9 y 6 ) 
COMMON  OVRBDN ( 28  y 6 ) y SOCECN ( 29  y 6 ) y SUBSG I ( 30  y 6 ) y SURH YD ( 23  y 6 ) 
COMMON  TGPS0I(33y6)  yOEGElMdOyd) 


CATEGORY  RESPONSE: 


COMMON  RANIMA(3) yRCLIMA(2) yRGENDE* 3) yRGRPHYCS) 
COMMON  R00RBD(7y 10) yRS0CEC(6) yRSUBS0(8) y RSURHY<6) 
COMMON  RT0PS0(9) yR0EGET(2) 

rEASIyTECONyOPUSE  SUBSYSTEM  PARAMETERS 

COMMON  CAAHM  y C ADAH  y CABFN ( 3 ) y C ABPP ( 3 ) y CAMBM 

COMMON  CABS ( 2 ) y CAC  y CACP  y CADE  y CADH 

COMMON  CADS  y GAEA!"  y CA{  !SAF  y CAHSTS  y CAI P 

COMMON  CAR3FC  y CASE y CASNC  y CSTES  y CSTRM 

COMMON  CSTRP  y FAOG  < 5 ) y PFSTSP  y PFAC  y RCLTEC  < 29  y 34 ) 

COMMON  TCAR ( 5 ) y THICK  d 0 ) y THKTS  y TTL ( 40 ) 


INTEGER  EXI T y CLMA  y ODES  y GWHY  y OOBD  y SBSL 
INTEGER  SCEC  y SWHY  y TPSL  y 06TA  y ANIM 
INTEGER  CLIMAT  y GENDES  y GRWHYD  y OORBDN 
IN  1 EGER  SOCECN y SUBGOi ySURHYDyTOPSOI 
INTEGER  OEGETAy ANIMAL 

I NTEGER  RCLIMA  y RGENDE  y RGRUHY  ? ROURBD  y RSOCEC 
INI  EGER  RSUBSO  y RSURHY  y RTOPSO  y ROEGET  y RANIMA 
INTEGER  RCLTEC y TTL 


INTEGER  COMMON  d) 
EQUIVALENCE  (COMMON  (1) 
EQUIVALENCE  dARRY  d)y 
EQUIVALENCE  (IARY2  d)y 
EQUIVALENCE-  (IARY2  <2)y 
EQUIVALENCE  (1ARY2  (3)y 
EQUIVALENCE  (IARY2  (4)y 


ITEM  d)) 
LUT) 

IGTRK) 

I3ECT) 

ICGDE) 

LEN) 


LOGICAL  LER 


DISPLAY  MODE 

1 IF  (, NOT ♦LER)  GOTO  5 
CALL  ERASE 
CALL  HOME 


3 GOTO  d0v20y30)  MOTE 
10  lOdiL  (LUT  d 010) 
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0111 

GOTO  40 

0112 

20 

OJRITE  < LOT  y 2010) 

0113 

GOTO  40 

0114 

30 

WRITE  ( LOT y 3010) 

0115 

40 

IF-  < MODE^GT*!)  GOTO  50 

0116 

GOTO  (100y200)  LEXIT 

0 1 1 7 

C 

. USER  INPUT  EDIT  F-iEADING 

0118 

*-".A 

w w 

WRITE  <LUly2020) 

0 1 1 9 

t.*  *i 

vJ  1 

READ  (LUTy2030)  IANS 

0120 

If-  (IANS*EQ.2HA  ) GOTO  100 

0121 

IF  (IANS*EQ*2HD  ) GOTO  200 

0122 

IF  < IANS*EG.21-IN0)  RETURN 

0123 

WRITE  (LUT?1200) 

0124 

GOTO  51 

0125 

L.* 

EDIT  EXPECTATIONS 

I--',  •{ 

w-  J.  il.  \J 

c 

USER  INPUT  ->  SUBHEADING  NUHBER 

V'  X X.  / 

WRITE  <LU1?3020) 

01 2S 

cr  -} 
\J  / 

READ  <LUTy^:)  11 

0129 

GOTO  85 

0130 

c 

USER  INPUI  ->  LAND  USE  OPTION  RE 

0 1 3 1 

53 

WRITE  <LUTy3030) 

0132 

54 

READ  (LUT?^)  LUORN 

0133 

IF  < LUORN *GE»1* AND.LUORN.ee. 6)  GOTO  56 

0134 

WRITE  <LUr?1200) 

0135 

GOTO  54 

0136 

56 

II  = II  T L 

0137 

u* 

USER  INPUT  ->  EXPECTATION  OALUE 

0138 

C"  O 

WRITE  (LUI y 3040) 

0139 

C-".  Q 

\j  / 

READ  (LUT?^)  OEGETA  ( II y LUORN) 

1^  i A A 
'■u  J.  *ir  V 


i " ' ' ■< 

J.  S X 


1 1-'  i::'  M ? t w r-  «;••  c 

! W l_  l 1 1 i X>  L_  1 S. 


JL 

I 


IF-  (MEGETA  <ii?LUGF=:N)  .GE.O.ANIUGEGETA  ( 1 1 y LUORH ) . LE  . 4 ) 
GOTO  600 


0142 

WRITE  (LUI?3050) 

0143 

GOTO  59 

0144 

C 

EDIT  RESPONSES 

0 1 4 5 

60 

I OLD  = ROEGEf  (NN) 

0146 

65 

WRITE  (LUIy2040)  IGLD 

0147 

GOTO  83 

0148 

C 

INPUT  RESPONSES 

0149 

C 

USER  INPUT  -->  ROEGET  <NN) 

0150 

70 

WRITE  (LUT?2000) 

0151 

O-T 

READ  (LUTy^O  ROEGET 

(NN) 

0152 

IF  (RMEGET  (NN). 

EQ.O) 

GOTO 

(900y87)  NODE 

0153 

II  ==  RUEGET  (NN) 

0154 

IF  (11 .GE.l .AND. 

II  .LE 

. lOEG 

(NN))  GFiTO  (700?  600 

0155 

87 

WRITE  (LUT?1200) 

0156 

GOTO  (83yG3y57)  NODE 

U X ^ / 

C 

DISPLAY  HE 

ADING 

A -“ 

PRIHARY  PLANT  TYPE 

4 v:  r*i 
* J X xj  O 

100 

NN  =-  1 

i L.'  1—1 

V X »J  ■/ 

J - 1 

0160 

L 0 

0161 

-•- p- ^ i")  V( ,'  jL-  1 /'■  i.n-» 

•i.  1 % 1 i w*  JL  * LL  V 1 V V jL  V n i t JL* 

.LER) 

CALL 

ERASE 

0162 

IF(NODE.NE< l.AND 

.LER) 

CALL 

HONE 

0163 

105 

WRITE  (LUTrlOOO)  ( 

• » r-  T A 
•v  i.T  1 ri 

( 1 y I ) y 

I ==  1?13) 

w J.  U.'  I 

WRITE  (LuTylOSO) 

0 1 c-  5 

Wi':irE  (LUTylOEO)  ( 

( vGT 

A / -f 

) V I x:  1-17)-  K =•-•  2?  4 

•71  6'-.‘ 

W7.  ilL  •H_Ul?il07)  ( 

\ '■  > i A 

< 5 y J ) 7 

1 IrlT)?  (VLTLiA 

; .1 
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0167 

0168 

0169 

0170 

0171 

0172 

0173 
017^ 

0175 

0176 

0177 

0178 

0179 

0180 
0181 
0182 

0183 

0184 

/\  i r\  ir.* 

\y  j.  i..»  uj 
0186 
0187 
0183 
0139 

0190 

0191 

r-.  -t  o *"> 

0193 

0194 

0195 

0196 

0197 

0198 
019? 
0200 
0201 
0202 

0203 

0204 

0205 

0206 
0207 
0203 

0209 

0210 
0211 
0212 


WRITE  <LUTyl050)  ( (OGTA  (Kyl)yX  = lyl3)yK  6y7) 

J J f 1 

no  110  K ==  Sylo 

\>IR  1 'I'  E (Eli  T y 1 1 00  ) C UGT  A ( K y I ) y I ~ 1 y 1 3 ) y ( OEGET  A < J y I ) y I 1 y 6 ) 

110  J J 1 

WRITE  (LUTylOGO)  ( (OGTA  (Kyl)yl  lyl3)yK  llyl2) 

WRITE  (LUTyllOO)  (OGTA  (13yI)yX  lyl3)y  (0E6ETA  ( J y 1 ) , I 1.8) 
GOTO  (70y60y52)  MODE 

C DI8PEAY  HE:ADIWG  h ->  BECCMDARY  TYPES 

200  MR  2 

J ==  IWEG  (1)  I 1 
L.  =-•  J 1 

I!"  (.MGT.LER)  GOTO  205 
CALL  ERASE 
GALL  ROME 
WRITE  ( LOT y 1000) 

205  WRITE  (LUTylC20) 

WRITE  ( LOT y 1050) 

WRITE  (LUTy 1050) 

WRITE  (EOT.  HOC) 

WRITE  (LUTy 1050) 

J =:  J f 1 

DO  210  K OylO 

WRITE  (LUTyllOO) 

210  J J i 1 

WRITE  (LUTyllOO) 


(OGTA  (lyl)yl  lyl3) 

(08TA  (14yl)yl  lyl3) 
(WGTA  (4yl)yl  ==  lyl3) 
(081A  (5yl)yl  lyl3)y  ( 


I I !**•  r*  A 
V J H 


( J y I ) y I 1 y 6 ) 


( (VCTA  (Ryl)yl  lyl3)yK  ==  6y7) 

(OGTA  (Ryl)yl  iyl3)y  (OEGEIA  (Jyl)yl  =:=  ly6) 
(VGTA  (15yl)yl  lyl3)y  (OEGETA  (Jyl)yl  ==  ly6) 


GOTO  (70y60y52)  MODE 
C USER  INPUT  ->  MORE  EDITS  ? 

600  WRITE  (LUTy 3060) 

READ  (LUTy 2030)  IANS 

IP  (IANS♦^^E.2HYE)  RETURN 
GOTO  1 

C INPUT  MODE  DIRECT  TO  PROPER  HEADING 

700  IF  (NN.EQ.NOEG)  RETURN 
GOTO  200 

G USER  WANTS  OUT  -->  SET  EXIT  TO  ZERO  AND  RETURN 

900  EXIT  ==  0 
RETURN 

G FORMAT  STATEMENTS 

1000  FORMAT  ( 13A2y44  ( “ Y “ ) y / y 26X y H “ y 

^lOXy  •’STANDARD  EXPECTATIONS-  y 1 IX  y “ “ y / y 

S26Xy44  < - Y-  ) y/y26Xy  ^ YCPOPY- y2Xy 
J^-NATIOE-  y 2Xy  •'YWILDY-  y2Xy  - WATER  “ y3Xy 
% - YHI GHYOTHERY “ y / y 26X  y 

5“ YLANDYOEGETATIONYLIFEYREGREATIONYUSE  Y* y5Xy “ Y “ ) 

C 


C 2 J.  3 

1020 

FORMAi 

(70  (-Y“)y/y2 

6Xy  “ t ■’  4X  " Y 

“10X“Y  "4X''Y-10X“Y''4X'’>i 

i “ 5X  ■'  Y “ ) 

0214 

C 

0215 

1050 

FORMAI 

(13A2y -Y- y4Xy 

" Y“  y lOXy  " Y 

“ y y " Y " y 

0216 

SlOXy “ Y- 

y4Xy - Y- yUXy - Y 

0217 

0218 

G 

1100 

F^RHHT 

(13A2y 

0219 

‘w’  jL-  w 

G 

.-r  . . 

J,  W' 

ii  “ Y “11 

“ Y -11'' 

Y ''11“ 

Y “1,1“  Y “11“ 

Y - 11 

i ' r’r  pt 
i U.:  » > 1 > i •»  i 

(/'•YOU  HI, YE  i 

YPED  IN  AN 

ILLEGAL  A:'LWL;-w  " y 

i,  y-  -r  1 i 

Z;  / .•  J. 

E HYP  AiYYiREP 

S;T}T  •••■> 

'f  % 
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0223 


0224 

0223 

0226 

0227 

0228 

0229 

0230 

0231 

0232 

'%-•  r-.*  w* 

r *'  > ^ 

w .'1.  •'■f 

023  !_> 

0236 

0237 
0228 

0239 

0240 

0241 

0242 

0243 

0244 

0245 


0246 

0247 

0248 

0249 

0250 

0251 

0252 

0253 

0254 


o2!5b 

0256 

0257 
0253 
0259 


8 


2000  FORMAT  (‘•FNTFR  THE  APPROPRI ATE  * y 5X y 

S44  ( ) y/y  ‘^NUHBERy  OR  ZERO  TO  QUIT  ->  _") 

C 

1010  FGRiiAT  ( 17X“  INPUT  RESPONSEG/OEGETA  i ION  “ // ) 

c: 

2010  FORMAT  < 17X"EDI  T RESP0N3ES/VE6E1  A I lONV/O 

'2 

3010  FORMAT  < IFK^EUIT  EXPECTAT I GNG/OEGEI ATI ON “ // ) 


C 

2020  FORMAT  < 5X"IN  UHICH  HEADING  IS  YOUR  DESIRED  EDIT 
TUX*  (ENTER  AyRy  OR  NONE  ) ~>  „*) 


L.- 

2030  FORMAT  <A2) 

C 

2040  FORMA i ( 5X"Y0UR  CURRENT  RESPONSE  IS  ->*Ily//, 

T5X“  ENTER  YOUR  NEU!  RESPONSE  HERE  ->  „ *■  ) 

8 

3020  FORMAT  < 5X*IN  UHICH  BUD-HEADING  IS  THE  EXPECTATION  MALUE\/? 
SOX’*  YOU  WISH  TO  CHANGE  ? (ENTER  THE  APPROPRIATE  NUMBER)  ->  ) 

C 

3030  F0RMAT(/5X*SELEGT  THE  LAND  USE  OPTION  YOU  WISH  TO  CHANGE*/ 

> iX*  --I-  / -2-  / --3-  / --4-  / -5-  / -6-  /*/ 

> 1X*CRGPLAND/NAT.0EG./WILDLIFE/WAT.REC./HIGH  USE/  OTHER/* 

>/5X*ENlER  YOUR  SELECTION  HERE  ->  ) 

C 

3040  FORMAT  ( 5X*EN1ER  YOUR  NEW  EXPECTATION  OALUE  HERE  ->  _.  * ) 

C 

. 3050  FORMAT  (/y  SX^ERROR — > YOUR  EXPECTATION  OALUE  MUST  BE“/y 
%5X*0yly2y3y  OR  4 TO  AUGID  INiRGDUCING  A BIAS  ->  _*) 

C 

3060  FORMAT  ( 5X"ANY  MORE  EDITS  TO  UEGEiATIGN  ?*/y 
S5X'*  <YES  OR  NO)  ->  _ * ) 

C 

C 

END 

END$ 
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ccriG 

T-^00004 

IS  Or^ 

CR00015  U 

S Xi 

TO  00008  BEKS  R==^0000 

0001 

170*00 

COST 

PER 

A C H L 

TO 

APPLY  HAY  MULCH 

0002 

o ■;/ 1--. 

LOS  T 

PER 

ACRE 

TO 

BUY/ APPLY  HE RBiCIBE 

0003 

9 * 000 

COST 

F‘E1-: 

ACRE 

TO 

BUY  FERTILIZER  * N (’•[.OFD 

0004 

4 * 000 

COST 

PER 

ACRE 

TO 

1.  U Y F'  il  R T I L 1 Z F'  iT  1 N ( " M E B " ) 

0005 

1*000 

COS  1 

A I'.;  L 

TO 

BUY  FERTILIZER  1 N C-HIOFr 

) 

0006 

7 * 000 

COST 

{■■•ER 

ACRE 

ro 

BUY  FERTILIZER  1 P (''L-UU^) 

0007 

3*000 

COST 

f'ER 

Ac  RE 

TO 

BUY  FERTILIZER  1 P ("MED") 

0008 

* 750 

Oos  i 

1'  i;_  i \ 

ACRE 

TO 

BUY  FERTILIZER  * P (-H1GFP 

) 

0 (H/  9 

1 70  V 00 

COST 

PER 

ACRE 

TO 

BUY  HAY  HULCil 

0010 

4*000 

COST 

PER 

ACRE 

TO 

BUY  SEED  (CROPLAND) 

0011 

91 *650 

COST 

FT- R 

ACRE 

TO 

BUY  SELB  (NUEOi^ULlFE^UFElCy 

HOSE; 

00 1 2 

15*000 

COST 

F-ER 

ACF-E 

rOR  GRAINING 

0013 

10*500 

COST 

PER 

ACRE 

'10 

CHISEL  PLOU 

0014 

1 *000 

COST 

r‘ER 

ACRE 

TO 

DRILL  FERTILIZER 

0013 

1-  V / 5 ‘ j 

COST 

pi;:i> 

AC'C: 

TO 

BISC  AND  HARR OH 

0016 

3*750 

COST 

;-=ER 

ACRE 

TO 

DRILL  SEED 

0017 

40  * 000 

COST 

r EF: 

ACRE 

TO 

ERECT  ANIMAL  FENCING 

0(;  1 0 

400*00 

COST 

[NCR 

A(72!:: 

TO 

HYDROMULCH  SEED  AND  FERTILIZER 

0019 

150*00 

COS"' 

PER 

ACRE 

TO 

HAND  PLANT  SHRUD  AND  TREE 

SEEDLINGS 

0020 

33*000 

COST 

PER 

ACRE 

TO 

IRRIGATE  PLANTINGS 

0021 

450  * 00 

COST 

IN3R 

ACRE 

TO 

RIP  THREE  FOOT  CENTERS 

r.  .*•»  .•••, 

\ * ■■ 

j 6 * 500 

COST 

ri  r-  .•■■t 
i Li.  1 *•. 

ACRE 

FOR  SNOW  FENCING 

0023 

•**?  cr 

■6;>  V y .j  1^* 

COST 

F-ER 

ACRE 

TO 

SEED  NURSE  CROP 

‘w*  ^*6 

10*000 

prCCEMTA; 

SE  F'OR 

STABILIZATION  OF  TOPSOIL  STORAGE  PILE 

0025 

15*000 

PERCENTAGE  FOR 

administration  costs 
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0012 
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0014 
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0015 
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0016 

11.5 

0017 
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U.  y w 

001? 
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0010 
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0011 
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0010 
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INTEGER  EIADX  (3) 

r-'.  .•••,  c:, 

V'  iJ  ' t 

Dm  I A LlAIiA  /2FiLl  y CKiTB?  Ci  / 
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0055 

CALL  8UAPC  (EIAUX) 

0056 

RETURN 

0057 

END 

0058 

c 

0059 

c 

ENOIRONMENTAL  DATA  EXECUTIOE 

(FULL  D 

0060 

c 

0061 

8UDR0UTINE  EIFD 

0062 

COMMON  ICOM  <6176) 

0063 

INTEGER  EIFDX  <3) 

0064 

DATA  EIFDX  /2HE I ? 2HFD » 2HX  / 

0065 

CALL  SWAPC  (EIFDX) 

0066 

RE TURN 

0067 

END 

0068 

c 

0069 

c 

ENOIRONMENl AL  DATA  DISPLAY  - 

SE6MEM 

0070 

c 

0071 

SUDROUTINE  DCDSl 

0072 

COMMON  ICOM  (6176) 

0073 

INTEGER  DCDSX  (3) 

0074 

DATA  DCDSX  /2HDC y 2HDS y 2HX  / 

0075 

CALL  SWAPC  (DCDSX) 

0076 

RE  1 URN 

0077 

END 

o 

o 

c 

0079 

c 

ENOIRONMENTAL  DATA  DISPLAY  - 

SEGMEN 

0080 

c 

0081 

SUBROUTINE  DCDS2 

0082 

COMMON  ICOM  (6176) 

0083 

INTEGER  DCDSO  (3) 

0084 

DATA  DCDSO  /2HDC y 2HDS » 2H0  / 

0085 

CALL  SUAPC  (DCDSO) 

0036 

RETURN 

0087 

END 

0088 

c 

0089 

c 

EXPECTATION  OALUES  DISPLAY 

0090 

c 

0091 

SUBROUTINE  DCEO 

0092 

COMMON  ICOM  (6176) 

0093 

INTEGER  DCEOX  (3) 

0094 

DATA  DCEOX  /2HDC ? 2HE0 y 2HX  / 

0095 

CALL  SWAPC  (DCEOX) 

0096 

RETURN 

0097 

END 

0098 

c 

0099 

c 

ENO I RONMENT AL  FE AS 1 B I L I T Y 

0100 

c 

Old 

SUBROUTINE  FEASI 

0102 

COMMON  ICOM  (6176) 

0103 

INTEGER  FEASX  (3) 

0104 

DATA  FEASX  /2HFE y 2HAS y 2HX  / 

0105 

CALL  SWAPC  (FEASX  ) 

0106 

RE  TURN 

0107 

END 

0108 

c 

0109 

TECHNIQUES  AND  ECONOMICS 

0110 

c 
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0111 

SUBROUTINE 

0112 

COHMON  ICON 

0113 

INTEGER 

0114 

DATA  TECOX 

0115 

CALL  SUAPC 

0116 

RETURN 

0117 

END 

0118 

C 

0119 

C 

OPT I HUH  USE 

0120 

C 

0121 

SUBROUTINE 

0122 

COHHON  ICON 

0123 

INTEGER 

0124 

DATA  OPUSX 

0125 

CALL  SUAPC 

0126 

RETURN 

0127 

END 

0128 

C 

0129 

C 

TRUCK  AND  S 

0130 

C 

0131 

SUBROUTINE 

0132 

COHHON  ICON 

0133 

INTEGER 

0134 

DATA  TSGEX 

0135 

CALL  SWAPC 

0136 

RETURN 

0137 

END 

0138 

END$ 

Tt:(:oN 

(6176) 

TMCOX  (3) 
/2HTE?2HCOy2HX  / 
(TtXOX) 


OPUSE 

(6176) 

OPUSX  (3) 
/2HOp72HUSy 2HX  / 
(OPUSX) 


HOUEL  GRADING  EXECUTIVE 

TSGE 

(6176) 

TSGEX  (3) 
/2HTSir2H6E^2HX  / 

(TSGEX) 
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XCLIMX  T=-- 0000-1  IS  ON  CROOOltii  USING  00004  BLKS  R=0000 


0001 

FTN4 

0002 

C 

0003 

C 

CLIMA  SCHEDULING  F’RDGRAM  - CLAIM  SWAP  CONTROL 

0004 

C 

OOOU 

PROGRAM  CL I MX 

0006 

C 

0007 

COMMON  ICOM  <6176) 

0008 

C 

0009 

EQUIOALENCE  (ICOM  (51).  ISTRK)y 

0010 

> (ICOM  (52) y ISECT)y 

0011 

> (ICOM  (53)y  ICODD? 

0012 

> (ICOM  (54)?  LEN) 

0013 

C 

0014 

C 

RECOOER  PARAMETERS 

00  lU 

C 

0016 

CALL  RMPAR  (ICOM  (51)) 

0017 

C 

0018 

C 

READ  COMMON  FROM  Tf^E  DISC 

0019 

C 

0020 

CALL  EXEC  (1?66?IC0M?6144?ISTRK?ISECT) 

0021 

CALL  EXEC  ( 1 ?66? 1C0M(6145) ? LEN ? ISTRK+1 ? ISECT) 

0022 

C 

0023 

C 

SCHEDULE  CLIMA 

0024 

C 

0025 

CALL  CLIMA 

0026 

C 

0027 

C 

WRITE  COMMON  BACK  TO  THE  DISC 

0028 

C 

0029 

CALL  EXEC  ( 2 ? 66  ? I COM  ? 6 1 44  ? I STRK  ? I SECT ) 

0030 

CALL  EXEC  (2?66? 1C0M(6145) ? LEN ? ISTRKT 1 ? ISECT) 

0031 

c 

0032 

END 

0033 

t:ND$ 
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SDCDSO  T=00004  IS  ON  CF^OOOIS  USING  00004  BLKS  R=0000 


0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 
OOOV 
0010 
0011 
0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 
002? 

0030 

0031 

0032 

0033 


FTN4 

C 

C tt  DCDS2  SCHEHUL1N6  FTvOGRAM  - CLAIM  SWAP  CONTROL  tt 

C 

PROGRAM  DCDSO 
C 

COMMON  I COM  (6176) 

C 

L"QU  I VALENCE  (I  COM  (51  1STRK)» 

> (ICOM  (52)j  ISECT)y 

> (ICOM  (53)j  I CODE)? 

> (ICOM  (54)y  LEN) 

C 

C RECOVER  PARAMETERS 

C 

CALL  RMPAR  (ICOM  (51)) 

C 

C READ  COMMON  FROM  THE  DISC 

C 

CALL  EXEC  (ly66y IC0My6144^ISTRK?ISECT) 

CALL  EXEC  (l»66yIC0M(6145)?LEN>ISTRKTl?ISECT) 

C 

C SCHEDULE  DCDS2 

C 

CALL  DCDS2 
C 

C WRITE  COMMON  BACK  TO  THE  DISC 

C 

CALL  EXEC  (2y66y lC0My6144?ISTRK?ISECT) 

CALL  EXEC  (2»66y IC0M(6145) jLENj ISTRK-M  y ISECT) 

C 

END 

END$ 
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^DCDSX  T=^00004  IS  ON  CROOOll:..  USING  00004  BLKS  Fv  = 0000 


0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 


KTN4 

C 

C tt  DCDSl  SCHEDULING  PROGF.'AH  - CLAIH  SNAP  CONTROL 

PF\‘06RAM  DCDSX 
C 

CONHON  ICON  (6176) 

C 

EQUIVALENCE  (ICOM  (51)?  ISTRK)? 

> (ICON  (52)?  ISECD? 

> (ICOM  (53)?  ICODE)? 

> (ICOM  (54)?  LEN) 

C 

C RECOVER  PARAMETERS 

C 

CALL  RMPAR  (ICOM  (51)) 

C 

C READ  COMMON  PROM  THE  DISC 

C 

CALL  EXEC  ( 1 ? 66? I COM? 61 44? ISTRK? I SECT) 

CALL  EXEC  ( 1 ?66? IC0MC6145) ?LEN? ISTRKTl ? ISECT) 

C 

C SCHEDULE  DCDSl 

C 

CALL  DCDSl 
C 

C WRITE  COMMON  BACK  TO  THE  DISC 

C 

CALL  EXEC  (2?66?IC0M?6144?ISTRK?1SECT) 

CALL  EXEC  (2?66? IC0M(6145) ?LEN? ISTRK-M  ? ISECT) 

C 

END 

END$ 
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SDCEUX  1=00004  IS  ON  CROOOIS  USING  00004  BLKS  R=003S 


■A 


0001 

FTN4 

0002 

C 

0003 

C 

DCEO  SCHEDULING  PROGRAM  - CLAIM  SWAP 

0004 

C 

OOOS 

PROGRAM  DCE'v'X 

0006 

C 

0007 

COMMON  ICOM  (6176) 

0008 

C 

0009 

EQUIOALENCE  (ICOM  (51) r ISTRK)» 

0010 

> (ICOM  (52)y  ISECT)? 

0011 

> (ICOM  (S3)?  ICODD? 

0012 

> (ICOM  (54)?  LEN) 

0013 

C 

0014 

C 

RECOVER  PARAMETERS 

00  IS 

C 

0016 

CALL  RMPAR  (ICOM  (51)) 

0017 

C 

0018 

C 

READ  COMMON  FROM  THE  DISC 

0019 

C 

0020 

CALL  EXEC  (1?66?IC0M?6144?ISTRK?ISECT) 

0021 

CALL  EXEC  (l?66yICDM(6145)5LEN?ISTRKM? 

0022 

C 

0023 

C 

SCHEDULE  DCEO 

0024 

C 

002S 

CALL  DCEO 

0026 

C 

0027 

c 

URITE  COMMON  BACK  TO  THE  DISC 

0028 

c 

0029 

CALL  EXEC  (2?66? IC0M?6144? ISTRK? ISECT) 

0030 

CALL  EXEC  (2?66?IC0M(6145) ?LEN?ISTRKfl? 

0031 

c 

0032 

END 

0033 

END$ 
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&DLDCX  1=00004  IS  ON  CR00015  USING  00005  BLKS  R=0037 


0001 

0002 

0003 

0004 

0005 

0006 
0007 
OOOB 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0036 

0037 


{••TN4 

PROGf^’AM  DLDCX 
C 

C PROGRAH  DLDCX  IS  SWAPPED  IN  BY  THE  DLGE  EXECUTIVE*  AFTER 
C READING  COMNON  FROH  THE  DXSKy  DLDCX  CALLS  SUBROUTINE  DLDCS» 

C TO  DISPLAY  CURRENT  SLOPES  AND  PERCENTS  AND  ALLOW  USER  MODIFICATION 
C TO  THEM* 

C BEFORE  TERMINATION^  DLDCX  WRITE  COMMON  BACK  TO  THE  DISK* 

C 

COMMON  ICON  (6176) 

C 

C 

EQUIVALENCE  <ICOM  (51)?  ISTRK)? 

> (ICON  (52)?  ISECT)? 

> (ICON  (53)?  I CODE)? 

> (ICOM  (54)?  LEN) 

C 

C RECOVER  PARAMETERS 

C 

CALL  RMPAR  (ICOM  (51)) 

C 

C READ  COMMON  FROM  THE  DISC 

C 

CALL  EXEC  (1?66?IC0M?6144?ISTRK?ISECT) 

CALL  EXEC  (i?66?IC0M(6145) ?LEN?ISTRKT1?ISECT) 

C 

C SCHEDULE  DLDCS 

C 

CALL  DLDCS 
C 

C WRITE  COMMON  BACK  TO  THE  DISC 

C 

CALL  EXEC  (2?66?IC0M?6144?ISTRK?1SECT) 

CALL  EXEC  (2?66?IC0M(6145)?LEN?1BTRK-M?ISECT) 

C 

END 

END$ 
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&DL6EB  T=:00004  IS  ON  CR00015  USING  00004  BLKS  R=0024 


0001  FTN4 

0002  C 

0003  C THESE  ARE  THE  "DUMMY-  SUBROUTINES  CALLED  BY  DLGE 

0004  C THAT  REQUIRE  SWAP  CONTROL 
0003  C 

0006  C SOURCE  FILE  5 &DLGES 

0007  C OBJECT  FILE  I %DLGES 


0008  C 

0009  C 

0010 
0011 
0012 

0013 

0014 

0015 

0016 

0017  C 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025  C 

0026 

0027 

0028 

0029 

0030 

0031 

0032  C 

0033 

0034 

0035 

0036 

0037 

0038 

0039  END$ 


SUBROUTINE  DLRLE 
COMMON  ICON  (6176) 

INTEGER  DLRLX  (3) 

DATA  DLRLX  /2HDL ? 2HRL y 2HX  / 
CALL  SWAPC  (DLRLX) 

RETURN 

END 

SUBROUTINE  BEST 
COMMON  I COM  (6176) 

INTEGER  DLSTX(3) 

D A T A D L.  S 1 X / 2 {-1 B L.  ? 2 H S T ? 2 H X / 
CALL  SWAPC (DLSTX) 

RETURN 

END 


SUBROUTINE  DLRSL 
COMMON  ICON  (6176) 

INTEGER  DLRSX(3) 

DATA  DLRSX/2HDL.y2HRSy2HX  / 
CALL  SWAPC (DLRSX) 

END 


SUBROUTINE  DLDCS 
COMMON  ICOM  (6176) 

IN f EGER  DLDCX(3) 

DATA  DLDCX/2HDLy2HDCy2HX  / 
CALL  SWAPC (DLDCX) 

END 
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SDLGEX  T=:00004  IS  ON  CROOOlO  USING  00004  BLKS  R-0000 


0001 

0002 

0003 

0004 
0003 
0006 

0007 

0008 

0009 

0010 
0 0 1 1 
0012 

0013 

00 1 4 
0013 
0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 

0034 

0035 

0 0 Cf 


FTN4 

PRGGF^AH  IU...GEX 
C 

C PROGRAH  DLGEX  IS  SUAPPEB  IN  BY  THE  CLAIM  EXECUTIOE*  AFTER 
C READING  COMNGN  FROM  THE  DISK-*  DLGEX  CALLS  SUBROUTINE  DLGE? 
C THE  DRAGLINE  GRADING  EXECUTIVE.  BEIORE  TERMINATION?  DLGEX 
C WRITES  COMMON  BACK  TO  THE  DISK< 

C 

COMMON  ICOM  (6176) 

C 

C 

EQUIVALENCE  (ICON  (51)?  ISIRK)? 

> (ICOM  (52)?  ISECT)? 

> (ICOM  (53)?  I CODE)? 

> (ICOM  (54)?  LEN) 

C 

C RECOVER  PARAMETERS 

C 

CALL  RMPAR  (ICOM  (51)) 

I-' 

C READ  COMMON  FROM  THE  DISC 

C 

CALL  EXEC  (1?66?IC0M?6144?1STRK?ISECT) 

CALL  EXEC  ( 1 ?66? ICGM(6145) ?LEN? ISTRKTl ? ISECT) 

C 

C SCHEDULE  DLGE 

C 

CALL  DLGE 

r- 

U.* 

C WRITE  COMMON  BACK  TO  THE  DISC 

C 

CALL  EXEC  (2?66? IC0M?6144? ISTRK? ISECT) 

CALL  EXEC  (2?66?1C0M(6145)?LEN?ISTRKT1?ISECT) 

C 

END 

ENDT- 


( 
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SDLRLX  T=--^00004  IS  ON  CROOOlO  USING  00004  BLKS  R=0031 


0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 


FTN4 

PROGRAM  DLRLX 
C 

C LiLRLE  SCHEDULING  PROGRAM 
C 

COMMON  I COM  (6176) 

EQUIOALENCE  (ICON  (51) » ISTRK). 

> (I COM  (52)j  I SECT)? 

> (I COM  (53)?  I CODE)? 

> (ICON  (54)?  LEN) 

C 

C RECOUER  PARAMETERS 

C 

CALL  RMPAR  (I COM  (51)) 

C 

C READ  COMMON  FROM  THE  DISK 

C 

CALL  EXEC  (1?66?IC0M?6144?ISTRK?ISECT) 

CALL  EXEC  (1?66?IC0M(6145) ?LEN?ISTRK-M?ISECT) 
C 

C SCHEDULE  DLRLE 

C 

CALL  DLRLE 
C 

C WRITE  COMMON  BACK  TO  THE  DISK 

C 

CALL  EXEC  (2?66? IC0M?6144? ISTRK?ISECT) 

CALL  EXEC  (2?66?IC0M(6145) ?LEN?ISTRKT1?ISECT) 
C 

END 

END$ 
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?.DLRLS  T=:00004  IS  ON  CROOOIS  USING  00005  BLKS  R:-=003S 


0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 


FIN  4 

SUBROUTINE  GRAF'S 
COMHON  ICON (61 76) 

CONNON  /TABLE/  KTAB(114) 

INTEGER  KARRAY(146)  yKF-‘ARAN(5)  ?GRAFX(3) 
EQUIOALENCE(KF--ARAM(  1 ) y ISTRK)  ? (KRARAN(2)  ? ISECT)  ? 
> (KPARAH(3)  ? ICODE)  ? (KF-’ARAM<4)  ?LEN) 

BATA  6RAFX/2F-IGR?2F1AF?2HX  / 

CALL  EXEC  (15?2yISTRK?lBISCyISECT) 

ISECT  =-  0 

DO  100  K =:  6145y6176 

KARRAY(K-“6144)  ==  ICOM(K) 


100 


200 


CONTINUE 
DO  200  K 


146 

KTAB(K- 


KARRAY(K) 

CON  "I  INUE 

CALL  IDSEG  (GRAFX?1) 

EXEC(2? 66? ICON? 6144? ISTRK? ISECT) 
EXEC(2?66?  KAF:;RAY?  146?  ISTRKTl  y ISECT) 
EXEC ( 9? GRAFX? ISTRK? ISECT? I CODE? LEN) 
EXECd  ? 66?  ICON  ?6 144?  ISTRK?  ISECT) 
EXEC< 1 ?66?KARRAY? 146? ISTRKTl ? ISECT) 
IDSEG  (GRAFX?2) 

6145?  6176 
= KARRAY(K“6144) 


300 


CALL 
CALL 
CALL 
CALL 
CALL 
CALL- 
DO  300  K 
ICOM(K) 
CONTINUE 
DO  400  K == 
KTAB(K- 


33? 146 

:2)  KARRAY(K) 


400  CONTINUE 

CALL  EXEC(16? 2? ISTRK? IDI SC? ISECT) 
RETURN 


END$ 
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&DLR3X  T=-00004  IS  ON  CR00015  USING  00004  BLKS  R=:^0034 


0001 

0002 

0003 

0004 


KTN4 


C 


PROGRAM  DLRSX 


C THIS  PROGRAM  IS  SWAPPED  IN  BY  DLGE  TO  SCHEDULE  DLRSL 


0005 

C 

- 

0006 

C 

0007 

C ttt 

CLAIM  RELEASE  1^0  - MARC 

0008 

C 

0009 

COMMON  ICOM  <6176) 

0010 

C 

0011 

C 

0012 

EQUIOALENCE  (ICOM  (51)?  ISTRK)? 

0013 

> (ICOM  <52)7  I SECT) 7 

0014 

> (ICOM  (53)?  I CODE) 7 

0015 

> (ICOM  (54)7  LEN) 

0016 

c 

0017 

c 

RECOOER  PARAMETERS 

0018 

c 

0019 

CALL  RMPAR  (ICOM  (51)) 

0020 

c 

0021 

c 

READ  COMMON  FROM  THE  DISC 

0022 

c 

0023 

CALL  EXEC  (1?66?IC0M761447ISTRK 

0024 

CALL  EXEC  ( 1 7667 IC0M(6145) ?LEN? 

0025 

c 

0026 

CALL  DLRSL 

0027 

c 

0028 

c 

WRITE  COMMON  BACK  TO  THE  DISC 

0029 

c 

0030 

CALL  EXEC  (2?66? iCDM76144? ISTRK 

0031 

CALL  EXEC  (27  66  ? 1 COM (614 5 ) ? LEN  ? 

0032 

c 

0033 

END 

0034 

ENDH' 
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&DLSTX  1^:^00001  IS  ON  CF:0001S  USING  00004  SLKS  10^^^0036 


0001  FTM4 

0002  PROGRAM  DLSTX 

0003  C 

0004  C PROGRAM  OLSTX  IS  SUAPPPi.1  IN  BY  THE  DLGE:  EXECUriOE.  AFTER 
0000  C READING  CUMMGi^  FROM  THE  DlSKv  DLSIX  CALLS  SUBROUTINE  BEST? 

0006  C TO  PRINT  TABLES  OF  THE  SUMMARY  DATA. 

0007  C BEFORE  TERM  I NAT  I Gib  BLSTX  UF;1TE  COMMON  BACK  TO  THE  DISK. 


0008  C 


0009 

COMMON  ICON 

( 6176 ) 

0010  C 

0011  c 

0012 

EQUIOALENCE 

( ICOM 

(31  ) ? 

1 S i iR  i \ ) P 

0013 

( I COM 

(32)  ? 

I SECT) ? 

0014 

( ICOM 

(33)  ^ 

ICODE) ? 

0013 

(ICOM 

(34)  ? 

L.EN ) 

0016  C 

0 0 1 /'  14  i".  C LJ  V L l4  1”‘  A i4  A M IT.  I fc;.  R S 

0018  C 

0019  CALL  RMPAR  (I COM  (01)) 


0020  C 

0021  C 

0022  C 

0023 

0024 
0023  C 

0026  C 

0027  C 


READ  COMMON  FROM  THE  DISC 

CALL  EXEC  ( 1 1-66:.  IC0M?6144:;  ISTRK?  ISECT) 

CALL  EXEC  ( 1 ? 66  ^ I COM (6143)?  LEN  ? I STRKT 1 ? I SECT ) 

SCHEDULE  DEBT 


0028  CALL  DEBT 

0029  C 

0030  C URITE  COMMON  BACK  TO  THE  DISC 

0031  C 

0 O 3 2 C A L L E X E C ( 2 ? 6 6 ? 1 C LJ  M ? 6 1 4 4 ? I S ( F\  T\  ? 1 S E C f ) 

0033  CALL  EXEC  ( 2 ? 66 ? I COM ( 61 43 ) ? LEM ? I STRKT 1 ? I SECT) 

0034  C 

0033  END 

0036  ENDT 


4H4 


seiaux  t-00004 


IS 


UM  CEOOOIS  USING  00004  BLKi 


l-^^^OOOO 


0001  rTN4 

0002  C 

0003  C tt  El  All  SSHEDULING  F-ROGRAH  - CLAIH 

0004  U 

0005  F-'ROGRAN  EIADX 

0006  C 

0007  CGnMGM  ICON  <6176) 

OOOS  C 


0009 

EGUIO'ALENCE  ( ICON 

(31  ) ? 

IS IRK) ? 

0010 

> <1C0N 

( 52  ) y 

ISECT) 7 

001 1 

> (ICGN 

(53)7 

I CODE ) 7 

0012 

0013 

C 

> (iCGn 

( 54 ) ? 

LEN) 

00l4 

C 

RECGUER  PARAME TEF< 

0015 

0016 

L 

CALL  RnPAR  (ICON 

(51 ) ) 

0017 

0013 

C 

c 

READ  CONHGN  FRGN 

TFIE  D1 

SC 

SNAP  CGNlRGL 


0019  C 

0020  CALL  EXEC  ( 1 ? 66  ? I COM  s 6 1 44  ? I ST  RK  ? 1 SECT ) 

0021  CALL  F;:  X E C (i^66?XCDH(6l4G)yL  E N I S I ’ F < R 1 ^ I B E C T ) 


0022  C 

0023  C SCF-iEDULE  ElAD 

0024  C 


0025 

0 O 

C 

CALL 

El  AD 

0027 

C 

URITL 

CGHNUN  BACK  TO  TFIE  DISC 

0023 

0029 

i: 

CALL 

EXEC 

( 2 y 66  y 1 CON  7 6 1 4 4 7 I STRK  7 I SECT ) 

0030 

0031 

C 

CALL 

EXEC 

( 2 y 6 6 7 J.  L-  U F i ( 6 1 4 5 ) y L..  F;.  f s y 1 S 1 F • i\  1-  !L  7 I S t.  L.  f ) 

0032 

0033 

END$ 

END 
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SEIFDS 


Tn::00004  IS  ON  CF:0001S  USING  OOOOB  BLKS  K=^^0000 


0001  FTN4 


0002  C 

0003  C 

0004  C 
0 ' ) (/  5 Cj 
0006 

0007 

0008 

0009 

0010 
001 1 


FILE  : aEIFDS 

FIFO  SUBROUTINES  USING  CLAIM  SNAP  CuNTRuL 

SUBROUTINE  CL IMA 
COMMON  ICON  (6176) 

INfEGER  CL I MX  <3) 

BAIA  CLIMX  /2HCLy2HIM?2PX  / 

CALL  SUAPC  (CLIMX) 

RETUPN 


0012 

0013  C 

0014 
OOlU 
0016 

0017 

001 8 

0019 

0020 

0021  C 

0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029  C 

0030 

0031 

0032 

0033 


END 

SUDRGU  riNE 

TORSO 

COMMON  ICON 

( 1 7 6 ) 

1 1 1:;.  Ch.  ;■( 

TCPSX  (3) 

DATA  TOF-SX 

7 2 H i G:>2Pi  'S?2HX 

CALL  SUAPC 

( TO PCX ) 

RETURN 

END 

SUBROUTINE 

SUBSO 

COMMG)!  I COM 

(6176) 

IN  fEuEF' 

SUBSX  (3) 

DATA  SUBSX 

/2HSUp2HBS >2HX 

CALL  SUAPC 

(SUBSX) 

RETURN 

END 

SUBROUTINE 

GURBD 

COMMON  ICON 

( 6 j.  7 6 ) 

IN  TEGER 

OURBX  (3) 

DATA  OURBX 

/2H0U?2HRB?2HX 

0034 

003b 

0036 


CALL  SUAPC  (OURBX) 

RETURN 

END 


0037  C 

0038 

0039 

0040 

0041 

0042 

0043 

0044 

0045  C 

0046 

0047 

0048 

0049 

0050 

0051 

0052 

0053  C 

0054 


SUBROUTINE  SURHY 
COMMON  ICON  (6176) 

INTEGER  SURHX  (3) 

DATA  SURHX  /2HSU ? 2HRH ? 2HX  / 
CALL  SUAPC  (SURHX) 

RETURN 

END 

SUBROUTINE  GRUHV 
COMMON  I CUM  (6176) 

IN  i EGER  GRk'HX  (3) 

DATA  GRUHX  /2HGR  2HUH  ^ 2HX  / 
C A i..  L.  S U A l-  ‘ C)  ( G 1\  i’J  H X ) 

RE  r URN 
END 


UUDRDUriNE  OLGE i 
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OOS5 

cGhHON  icon 

(6176) 

0056 

IN lEGER 

OEGEX  (3) 

0 0 5 7 

DATA  OEGEX 

/2H0E?2HGE?2HX 

0058 

GALL  SWAPC 

(OEGEX) 

0059 

RETURN 

0 0 6 0 

END 

0061 

C 

- 

0062 

SUBROUTINE 

ANINa 

0063 

COMNGN  ICON 

\ Cj  1 / 6'  ) 

0064 

1 N 1 t:.  i:3  i::. 

A N I h X ( 3 ) 

0065 

DATA  AMI  NX 

/2HAMi-2HIHi>2HX 

0066 

GALL  SUaPC 

( ANI HX ) 

0067 

REI URN 

006S 

END 

0069 

C 

0070 

SUBROUTINE 

SOCEC 

0071 

COHMON  ICON 

(6176) 

0072 

INTEGER 

GOCEX  (3) 

0073 

DATA  SGGEX 

/2HS0?  2HCE  ? 2HX 

0074 

Call  suapc 

(BOCEX) 

0075 

RETURN 

0076 

END 

0077 

C 

007B 

l£ND$ 
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T=:^0 

0004  IS  ON  CF:00013  USING  00004  EL 

K S 

F 

=-0000 

0001 

F'rM4 

0002 

C 

0003 

c 

tt  EIF-D  SCHEDULING  P 

ROGR 

AM  CL 

AIM 

SWAP  CONTROL 

0004 

c 

0 0 0 5 

PROGRAM  EIFDX 

0006 

c 

0007 

A f'l  O 

COMMON  ICGM  (6176) 

w V V.-  O 

0009 

L- 

EQUIUALENCE  (ICOM  (3 

1 ) ? 

ISTRK) ? 

0010 

> (ICGM  (5 

2 ) j 

IBECT) ? 

0011 

> (ICOM  (3 

3 ) F 

I CODE ) V 

0012 

> (ICOM  (3 

4 ) ? 

LEN) 

0013 

c 

0014 

c 

RECOOER  PARAMETERS 

0013 

c 

0016 

CALL  RMPAR  (ICOM  (31 

) ) 

0017 

c 

0013 

c 

READ  COMMON  FROM  THE 

DIS 

C 

0019 

r 

V^‘ 

0020 

CALL  EXEC  (1?66?1C0M 

7 6 1 4 

4? ISTRK 

7 I 

SE 

CT) 

0021 
^•'1  i'',  '< 

CALL  EXEC  (lyoovlCOM 

(614 

3 ) 7 LEN  7 

IB 

lb 

KT 1 7 I SECT) 

0023 

L* 

c 

SCHEDULE  EIFD 

0024 

c 

0023 

CALL  EIFD 

0026 

c 

0027 

c 

URITE  COMMON  BACK  TO 

THE 

DISC 

0028 

c 

0029 

CALL  EXEC  ( 2 V 66? ICOM 

? 6 1 4 

4? ISTRK 

7 1 

SE 

CT) 

0030 

C A L..  E X L C ( 2 ? 6 6 ? I C 0 M 

(614 

3) 7 LEN 7 

IS 

TR 

Kil 7 1 SECT) 

0031  C 

0032  END 

0033  END$ 


I 
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1 

f 


SFEASX  T=:00004  IS  ON  Cfs‘00015  USING  00004  BLKS  K-OOOO 


0001 

FTN4 

0002 

C 

0003 

C 

FFASI  SCHEDULING  F’ROGRAM  - CLAIH  SWAP  CONTROL 

0004 

C 

0005 

PROGRAM  FEASX 

0006 

C 

0007 

COMMON  ICON  (6176) 

0008 

C 

OOOV 

EQUIOALENCE  (ICOM  (51 )y  ISTRK)? 

0010 

> (ICOM  (52)?  ISECT)? 

0011 

> (ICOM  (53)?  I CODE)? 

0012 

> (ICOM  (54)?  LEN) 

0013 

C 

0014 

C 

RECOOER  PARAMETERS 

0015 

C 

0016 

CALL  RMPAR  (ICOM  (51)) 

0017 

C 

0018 

C 

READ  COMMON  FROM  THE  DISC 

0019 

C 

0020 

CALL  EXEC  (1?66?IC0M?6144?1STRK?ISECT) 

0021 

CALL  EXEC  (1?66?IC0M(6145) ?LEN?ISTRK-M?ISECT) 

0022 

C 

0023 

c 

SCHEDULE  FEASI 

0024 

c 

0025 

CALL  FEASI 

0026 

c: 

0027 

c 

WRITE  COMMON  BACK  TO  THE  DISC 

0028 

c 

0029 

CALL  EXEC  (2? 66 ? ICOM? 6144? I STRK? I SECT) 

0030 

CALL  EXEC  (2?66? 1C0M(6145) ?LEN? ISTRK+1 ? ISECT) 

0031 

c 

0032 

END 

0033 

t;ND$ 
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000^ 
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0006 

0007 
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oooy 
0010 
0011 
0012 
0013 
001^ 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 
0029 


F-  TN4 
C 

C FILE  : SIGHS 

C I6D  SUBf^lOUriNES  USING  CLAIH  SNAP  CONTROL  tttt 

C 

SUBROUTINE  DLGE 
COMMON  I COM  (6176) 

INTEGER  HLGEX  (3) 

DATA  DLGEX  /2HDL » 2HGE » 2HX  / 

CALL  SWAPC  (DLGEX) 

RETURN 

END 

C 

SUBROUTINE  TSGE 
COMMON  I COM  (6176) 

INTEGER  TSGEX  (3) 

DATA  TSGEX  /2HTS » 2HGE r 2HX  / 

CALL  SWAPC  (TSGEX) 

RETURN 

END 

C 

SUBROUTINE  TSST 
COMMON  I COM  (6176) 

INTEGER  TSSTX  <3) 

DATA  TSSTX  /2HTS y 2HST y 2HX  / 

CALL  SUAPC  (TSSTX) 

RETURN 

END 

END$ 
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SGDE 

0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 

0011 

0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 

0021 

0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 


T=00004  IS  ON  CR00015  USING  00004  BLKS  R=0000 


FTN4 

PROGRAM  GDEX 
C 

C GDE  SCHEDULING  PROGRAM 
C 

COMMON  ICOM  (6176) 

C 

EQUIMALENCE  (ICOM  (51)?  ISTRK)? 

> (ICOM  (52)?  I SECT)? 

> (ICOM  (53)?  I CODE)? 

> (ICOM  (54)?  LEN) 

C 

C RECOVER  PARAMETERS 

C 

CALL  RMPAR  (ICOM  (51)) 

C 

C READ  COMMON  FROM  THE  DISC 

C 

CALL  EXEC  (1?66?IC0M?6144?ISTRK?ISECT) 

CALL  EXEC  (1?66?IC0M<6145)?LEM?ISTRK-M?ISECT) 
C 

C SCHEDULE  GDE 

C 

CALL  GDE 
C 

C WRITE  COMMON  BACK  TO 'THE  DISC 

C 

CALL  EXEC  (2?66?IC0M?6144?ISTRK?ISECT) 

CALL  EXEC  (2?66?IC0M(6145) ?L£N?ISTRK+1?ISECT) 
C 

END 

END$ 
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&GETIX  T-0000^  IS  ON  CROOOIS  USING  00004  BLKS  R=^0000 


0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 
0017 
00  IB 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 


FTN4 

C 

C tt  GETID  SCHEDULING  PROGRAM  ~ CLAIM  SWAP  CONTROL 

C 

PROGRAM  GET IX 
C 

COMMON  ICON  (6176) 

C 

EQUIOALENCE  (ICOM  (51),  ISTRK), 

> (ICOM  (52) y ISECT)y 

> (ICOM  (53) T ICODE)» 

> (ICOM  (54) r LEN) 

C 

C RECOMER  PARAMEIERS 

c: 

CALL  RMPAR  (ICOM  (51)) 

C 

C READ  COMMON  FROM  THE  DISC 

C 

CALL  EXEC  ( 1 »66t IC0Mj6144» ISTRKj ISECT) 

CALL  EXEC  (1?66?IC0M(6145)  >LENjISTRK-fl?ISECT) 

C 

C SCHEDULE  GETID 

C 

CALL  GETID 
C 

C WRITE  COMMON  PACK  TO  THE  DISC 

C 

CALL  EXEC  (2?66y IC0M?6144y ISTRKjISECT) 

CALL  EXEC  (2y66yIC0M(6145) yLENylSTRK+ly ISECT) 

C 

END 

END$ 
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&GRAFX  T=00004  IS  ON  CFx’OOOlS  USING  00005  BLKS  R=0043 


0001 

FTN4 

0002 

PROGRAM  GRAFX 

0003 

C 

0004 

C 

GRAFS  SCHEDULING  PROGRAM 

0005 

C 

0006 

COMMON  IC0M(6176) 

0007 

COMMON  /TABLE/  KTAB(114) 

0008 

INTEGER  KPARAM<5) yKARRAY( 146) 

0009 

EQUIVALENCE  (KPARAMd ) , ISTRK) * ( KPARAM ( 2 ) d SECT ) y 

0010 

> (KPARAM<3) > I CODE) y ( KPARAM < 4 ) j LEN ) 

0011 

C 

0012 

C 

RECOVER  PARAMETERS 

0013 

C 

0014 

CALL  RMPAR  (KPARAM) 

0015 

C 

0016 

C 

READ  FROM  THE  DISK 

0017 

C 

0018 

CALL  EXEC  (ly66dC0M?6144dSTRKdSECT) 

0019 

CALL  EXEC  (ly66yKARRAYy  146yISTRK-fljISECT) 

0020 

DO  100  K = 6145.*6176 

0021 

ICOM(K)  = KARRAY<K-6144) 

0022 

100 

CONTINUE 

0023 

DO  200  K = 33 » 146 

0024 

KTAB(K~32)  = KARRAY<K) 

0025 

200 

CONTINUE 

0026 

C 

0027 

C 

SCHEDULE  GRAFS 

0028 

C 

0029 

CALL  GRAFS 

0030 

c 

0031 

c 

WRITE  BACK  TO  THE  DISK 

0032 

c 

0033 

DO  300  K = 6145j6176 

0034 

KARRAY(K“6144)  = ICOM<K) 

0035 

300 

CONTINUE 

0036 

DO  400  K = 33d46 

0037 

KARRAY(KT32)  =••  KTAB(K) 

0038 

400 

CONTINUE 

0039 

c 

0040 

CALL  EXEC(2?66f KARRAYj61445 ISTRKy ISECT) 

0041 

CALL  EXEC  < 2 > 66  y KARRA Y < 6 1 45  ) t 1 46  ? ISTRK-f  1 y 1 SECT  ) 

0042 

END 

0043 

e;nlv$ 

f • 
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0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 


F TN4 
C 

C 6RWHY  SCHEDULING  PROGRAM  - CLAIM  SWAP  CONTROL  tt 

C 

PROGRAM  GRWHX 
C 

COMMON  I COM  (6176) 

C 

EQUIOALENCE  (ICOM  (51 ISTRK)y 

> (ICOM  (52),  ISECT), 

> (ICOM  (53),  I CODE), 

> (ICOM  (54),  LEN) 

C 

C RECOVER  PARAMETERS 

C 

CALL  RMPAR  (ICOM  (51)) 

C 

C READ  COMMON  FROM  THE  DISC 

C 

CALL  EXEC  (1,66, ICOM, 6144, ISTRK,ISECT) 

CALL  EXEC  (1,66,IC0M(6145) ,LEN,ISTRK+1,ISECT) 

C 

C SCHEDULE  GRWHV 

C 

CALL  GRWHY 
C 

C WRITE  COMMON  BACK  TO  THE  DISC 

C 

CALL  EXEC  (2,66, ICOM, 6144, ISTRK, ISECT) 

CALL  EXEC  (2,66, IC0M(6145) , LEN, lSTRK+1 , ISECT) 

C 

END 

END$ 
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SISNEX  T=00004  IS  ON  CROOOIS  USING  00004  BLKS  R=0000 


0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 


FTN4 

C 

C ISNtV  SCHEDULING  F’RGGRAM  - CLAIH  SWAP  CONTROL  tt 

C \/ 

PROGRAM  ISNEX 

C I 

COMMON  ICON  (6176)  I 

C I 

EQUIVALENCE  (ICOM  <51 )y  ISTRK)? 

(ICOM  (52) j ISECT)y 

> (ICOM  (53)j  ICODE)> 

> (ICOM  (54)5  LEN) 

C 

C RECOVER  PARAMETERS 

C 

CALL  RMPAR  (ICOM  (51)) 

C 

C READ  COMMON  FROM  THE  DISC 

C 

CALL  EXEC  ( 1 5665 ICOMy 61445 ISTRK? ISECT) 

CALL  EXEC  (ly66yIC0M(6145)yLENylSTRKTlyISECT) 

C 

C SCHEDULE  ISNEV 

C 

CALL  ISNEV 
C 

C WRITE  COMMON  BACK  TO  THE  DISC 

C 

CALL  EXEC  (2y66yIC0My6144yISTRKy ISECT) 

CALL  EXEC  (2y66yIC0H(6145)yLEN?ISTRK+lyISECT) 

C 

END 

END$ 
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&OPUBX  T=-00004  IS  GN  CR00015  USING  00004  BLKS  R=0000 


0001  RfN4 

0002  C 

0003  C 

0004  C 
COOS 

0006  C 

0007 
OOOfcl  C 

0009 

0010 
0011 
0012 

0013  C 

0014  C 

0015  C 

0016 

0017  C 

0018  C 

0019  C 

0020 
0021 

0022  C 

0023  C 

0024  C 

0025 

0026  C 

0027  C 

0028  C 

0029 

0030 

0031  t; 

0032 

0033  END$ 


tt  OPUSt;  SCHEDULING  PROGRAM  - CLAIM  SWAP  CONTROL  tt 

PROGRAM  OPUSX 

COMMON  ICOM  (6176) 

EQUIOALENCE  (ICOM  (51) > ISTRK)» 

(ICOM  (52)  > ISECDt 
(ICOM  (53)?  ICODE)? 

(ICOM  (54)?  LEN) 

RECOVER  PARAMETERS 

CALL  RMPAR  (ICOM  (51)) 

READ  COMMON  FROM  THE  DISC 

CALL  EXEC  (1?66?1C0M?6144?ISTRK?1SECT) 

CALL  EXEC  (1?66?1C0M(6145) ?LEN?ISTRK+1?ISECT) 

SCHEDULE  OPUSE 

CALL  OPUSE 

WRITE  COMMON  BACK  TO  THE  DISC 

CALL  EXEC  (2?66?IC0M?6144?ISTRK?ISECT) 

CALL  EXEC  (2?66?IC0M(6145)?LEN?ISTKK-M?ISECT) 


END 
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0001 

FTN4 

0002 

C 

0003 

C 

DMRBD  SCHEDULING  PRGGFn’AM  - CLAIM  SWAP  CONTROL  tt 

0004 

c 

0005 

progf:am  oorbx 

0006 

c 

0007 

COMMON  I COM  (6176) 

0008 

c 

0009 

EQU I VALENCE  (ICOM  (51)?  ISTRK)? 

0010 

> (ICOM  (52)?  ISECT)? 

0011 

> (ICOM  (53)?  I CODE) 7 

0012 

> (ICOM  (54)7  LEN) 

0013 

c 

0014 

c 

RECOVER  PARAMETERS 

0015 

c 

0016 

CALL  RMPAR  (ICOM  (51)) 

0017 

c 

0018 

c 

READ  COMMON  FROM  THE  DISC 

0019 

c 

0020 

CALL  EXEC  (l?667lC0M?61447lSTRK? ISECT) 

0021 

CALL  EXEC  (l766?IC0M(6145) 7LEN?lSTRK+l7lSECT) 

0022 

c 

0023 

c 

SCHEDULE  OVRBD 

0024 

c 

0025 

CALL  OVRBD 

0026 

c 

0027 

c 

WRITE  COMMON  BACK  TO  THE  DISC 

0028 

c 

0029 

CALL  EXEC  (2?667 IC0M?61447 ISTRK? ISECT) 

0030 

CALL  EXEC  (2?667lC0M(6145) 7LEN7lSTRK+lyISECT) 

0031 

c 

0032 

END 

0033 

417 


SSOCEX  T=-:00004  IS  ON  CROOOl!::  USING  00004  BLKS  R=^*0000 
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0017 

0018 

0019 

0020 
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0025 

0026 

0027 

0028 

0029 

0030 
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0032 

0033 


r IN4 
C 

C SOCEC  SCHEDULING  PROGRAH  - CLAIH  SWAP  CONTROL 

C 

PROGRAH  SOCEX 
C 

COHHON  ICON  (6176) 

C 

EQUIVALENCE  (ICON  (51) y ISTRK)y 

> (ICON  (52) y lSECT)y 

> (ICON  (53) y ICODE)y 

> (ICON  (54)y  LEN) 

C 

C RECOVER  PARAMETERS 

C 

CALL  RHPAR  (ICON  (51)) 

C 

C READ  COMMON  FROM  I HE  DISC 

C 

CALL  EXEC  (ly66yIC0My6144yISTRK'y  ISECT) 

CALL  EXEC  (ly66yIC0M(6145)yLENyISTRK+lyISECT) 

C 

C SCHEDULE  SOCEC 

C 

CALL  SOCEC 
C 

C UMa’ITE  common  BACK  TO  THE  DISC 

C 

CALL  EXEC  (2y66y lC0My6144y ISTRKy ISECT) 

CALL  EXEC  (2y66yIC0M(6145)yLENyISTRK-}*l?lSECT) 

C 

END 

END$ 
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0033 


FTN4 

C 

C tt  SRCD  SCHEDULING  PROGRAH  - CLAIM  SWAP  CONTROL  tt 

C 

PROGRAM  SRCDX 
C 

COMMON  ICON  (6176) 

C 

EQUIOALENCE  (ICON  (51 )r  ISTRK)> 

> (ICON  (52)  y ISECDj 

> (ICON  (53) » I CODE)? 

> (I COM  (54)y  LEN) 

C 

C RECOMER  PARAMETERS 

C 

CALL  RMPAR  (I COM  (51)) 

C 

C READ  COMMON  PROM  THE  DISC 

C 

CALL  EXEC  <ly66>IC0M?6144y ISTRKylSECT) 

CALL  EXEC  (ly66yIC0M(6145)yLENylSTRK+l?ISECT) 

C 

C SCHEDULE  SRCD 

C 

CALL  SRCD 
C 

C WRITE  COMMON  BACK  TO  THE  DISC 

C 

CALL  EXEC  <2?66yIC0M?6144?lSTRK?ISECT) 

CALL  EXEC  (2?66ylC0M(6145)fLENylSTRK-fl?ISECT) 

C 

END 

END$ 
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0030 

0031  C 
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0033  END$ 


SUBSO  SCHEDULING  PROGRAM  - CLAIM  SNAP  CONTROL 


PROGRAM  SUBSX 

COMMON  iCOM  (6176) 

EQUIVALENCE  (ICOM  (51) y 1STRK)t 
(ICOM  (52)y  ISECDy 
(ICOM  (53) y ICODE)y 
(ICOM  (54)y  LEN) 

RECOVER  PARAMETERS 

C A L_  L R M A R (ICOM  (51)) 


READ  COMMON  FROM  THE  DISC 

CALL  EXEC  (ly66y  IC0My6144ylSfRt\yISECT) 

CALL  EXEC  (ly66ylC0M(6145)yLENyiSTRK+lylSECT) 


SCHEDULE  SUBSO 


CALL  SUBSO 

URITE  COMMON  BACK  TO  THE  DISC 

CALL  EXEC  (2y66y  IC0My6144yISTRt<yISECT) 

CALL  EXEC  (2y66yIC0M(6145)yLENyISTRK41yISECT) 

END 
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0033 


f-TN4 

C 

C tt  SURHY  SCHEDULING  PROGRAM  - CLAIM  SWAP  CONTROL 

C 

PROGRAM  SLIRHX 
C 

COMMON  ICOM  (6176) 

C 

fOUIOALENCE  (ICOM  (51)?  ISTRK)? 

> (ICOM  (52)?  ISECT)? 

> (ICOM  (53)?  I CODE)? 

> (ICOM  (54)?  LEN) 

C 

C RECOMER  PARAMEIERS 

C 

CALL  RMPAR  (ICOM  (51)) 

C 

C READ  COMMON  FROM  THE  DISC 

C 

CALL  EXEC  (1?66?IC0M?6144?ISTRK?1SECT) 

CALL  EXEC  (1?66?IC0M(6145)?LEN?ISTRK+1?ISECT) 

C 

C SCHEDULE  SURHY 

C 

CALL  SURHY 
C 

C WRITE  COMMON  BACK  TO  THE  DISC 

C 

CALL  EXEC  (2?66?IC0M?6144?1STRK?1SECT) 

CALL  EXEC  (2?66?IC0M(6145)?LEN?1STRK+1?1SECT) 

C 

END 

END$ 
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STECOX  1=00004  IS  ON  CR00015  USING  00004  BLKS  R=0000 


0001 

0002 

0003 

0004 

0005 

0006 
0007 
OOOS 

0009 

0010 
0011 
0012 

0013 

0014 
0013 
0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 


FTN4 

C 

C 

C 


C 


C 


C 

C 

C 

C 

C 

C 


C 

G 


C 


C 


C 

C 

c 


END$ 


tt  TECON  SCHEDULING  PROGRAH  - CLAIM  SWAP  CONTROL  tt 

PROGRAM  TECOX 

COMMON  I COM  (6176) 

EOU I VALENCE  (ICOM  (51),  ISTRK) , 

(ICOM  (52),  ISECT), 

(ICOM  (53),  I CODE), 

(ICOM  (54),  LEN) 

RECOVER  PARAMETERS 

CALL  RMPAR  (ICOM  (51)) 

READ  COMMON  FROM  THE  DISC 

CALL  EXEC  (1,66, IC0M,6144,ISTRK, ISECT) 

CALL  EXEC  (1,66, IC0M(6145) , LEN, ISTRKTl, ISECT) 

SCHEDULE  TECON 

CALL  TECON 

WRITE  COMMON  DACK  TO  THE  DISC 

CALL  EXEC  (2,66, ICOM, 6144, ISTRK,1SECD 

CALL  EXEC  (2,66, IC0M(6145) , LEN, ISTRKfl, ISECT) 

END 
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&TFCDX  7=^00004  IS  ON  CROOOiei;  USING  00004  BLKS  R==-0033 


0001 

F TN4 

0002 

C 

0003 

C 

7FCD  SCHFDULING  F-‘ROGRAM 

0004 

C 

0005 

PROGRAM  TFCDX 

0006 

C 

0007 

COMMON  I COM  (6176) 

0008 

C 

0009 

FQUIOALFNCE  (ICDM  (51 )y  ISTRK), 

0010 

> (ICOM  (52)  y iSFCDy 

0011 

> (icon  (53)  y iconoy 

0012 

> (ICOM  (54) y LFN) 

0013 

C 

0014 

C 

RECOOFR  PARAMETERS 

0015 

C 

0016 

C A 1.  L R‘  M {”•  A R ( I C 0 M ( 51)) 

0017 

C 

0018 

C 

READ  COMMON  FROM  THE  DISC 

0019 

C 

0020 

CALL  EXEC  (ly66yIC0My6144y ISTRKylSECT) 

0021 

CALL  EXEC  (ly66ylC0M(6145)yLENyISTRKilyISECT) 

0022 

C 

0023 

C 

SCHEDULE  TFCD 

0024 

C 

0025 

CALL  TFCD 

0026 

C 

0027 

C 

WRITE  COMMON  BACK  TO  THE  DISC 

0028 

C 

0029 

CALL  EXEC  (2y66y IC0My6144y ISTRKy ISECT) 

0030 

CALL  EXEC  (2y66y IC0M(6145) yLENy XSTRKTl y ISECT) 

0031 

C 

0032 

END 

0033 

FNIi$ 
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8T0PSX  T=--^00004  IS  ON  CROOOIS  USING  00004  BLKS  R=0000 


0001 

0002 

0002 

0004 

0005 

0006 

0007 

0008 

0009 

0010 
0011 
0012 
00  5 3 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 


riN4 

c 


c 

c 

c 

c 


c 

c 

c 

c 

c 

c 


c 


c 

c 

c 

c: 

c 


c 


tt  TOPSO  SCHEDULING  PROGRAM  - CLAIM  SWAP  CONTROL 
PROGRAM  TCPSX 
COMMON  ICOM  (6176) 

ISTRK)? 

ISECT) ? 

I CODE.  ) ? 

LEN) 

RECOVER  PARAMETERS 

CALL  RMPAR  (ICOM  (51)) 

READ  COMMON  FROM  THE  DISC 

CALL  EXEC  (l?66?IC0M>6144?ISTRKy ISECT) 

CALL  EXEC  (l3.66?IC0M(6145)  yLEN?ISTRKTl?lSECT) 

SCHEDULE  TOPSO 

CALL  TOPSO 

WRITE  COMMON  BACK  TO  THE  DISC 

CALL  EXEC  (2j66» IC0My6144r ISTRK? ISECT) 

CALL  EXEC  (2y66»IC0M(6145)  jLEN?ISTRK-fl»ISECT) 

END 


EQUIVALENCE  (ICOM  (51)y 
(ICOM  (52)y 
(ICOM  (53)» 
(ICOM  (54) > 
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&TSGES  T = 00004  IS  ON  CROOOIS  USING  00007  BLKS  R==0000 


0001 

FTN4 

0002 

C 

0003 

C 

FILE  t ^TSGEG 

0004 

C 

tttt  TSGE  SUBROUTINES  USING  CLAIH  SOAP  CONTROL  tttt 

0005 

C 

0006 

SUBROUTINE  TSXBA 

0007 

COMMON  I COM  (6176) 

0008 

INTEGER  TSXBX  (3) 

0009 

DATA  TSXBX  / 2HTS»  2HXBt  2HX  / 

003  0 

CALL  SWAPC  (TSXBX) 

0011 

RETURN 

0012 

END 

0013 

C 

0014 

C 

0015 

SUBROUTINE  TSIHB 

0016 

COMMON  I COM  (6176) 

0017 

INTEGER  TSIHX  (3) 

0018 

DATA  TSIHX  /2HTS?  2HIH»  21 IX  / 

0019 

CALL  SUAPC  (TSIHX) 

0020 

RETURN 

0021 

END 

0022 

C 

0023 

SUBROUTINE  TSIFG 

0024 

COMMON  ICOM  (6176) 

0025 

INTEGER  TSIEX  (3) 

0026 

DATA  TSIFX  /2HTSy  2HIFy  2HX  / 

0027 

CALL  SWAPC  (TSIFX) 

0028 

RETURN 

0029 

END 

0030 

V. 

0031 

SUBROUTINE  TSJ.EN 

0032 

COMMON  ICOM  (6176) 

0033 

INTEGER  TSIEO  (3) 

0034 

DATA  TSIFO  /2HTSy  2HIF»  2H0  / 

0035 

CALL  SWAPC  (TSIFO) 

0036 

RETURN 

0037 

END 

0038 

C 

0039 

SUBROUTINE  TGSCI 

0040 

COMMON  ICOM  (6176) 

0041 

INTEGER  TSSCX  (3) 

0042 

BATA  TSSCX  / 2HTS?  2HSCy  2HX  / 

0043 

CALL  GUAPC  (TSSCX) 

0044 

RETURN 

0045 

END 

0046 

c 

004  7 

SUBROUTINE  TSSCF 

0048 

COMMON  ICOM  (6176) 

0049 

INTEGER  TSSCO  (3) 

0050 

DATA  TSSCO  /2HTSy  2HSCy  2H0  / 

0051 

CALL  SWAPC  (TSSCO) 

0052 

RETURN 

0053 

END 

0054 

c 
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0055 

0056 

0057 

0058 

0059 

0060 
0061 
0062 

0063 

0064 

0065 

0066 

0067 

0068 

0069 

0070 

0071 


SUBROUTINt:  TSXFS 
COMMON  ICON  (6176) 

INTEGER  TSXFX  <3) 

DATA  TSXFX  / 2HTS?  2HXF,  2HX  / 
CALL  SWAF’C  (TSXFX) 

RETURN 

END 

C 

SUBROUTINE  TSXST 
COMMON  ICON  (6176) 

INTEGER  TSXSX  (3) 

DATA  TSXSX  /2HTS  » 2HXS 2HX  / 

CALL  SWAPC  (TSXSX) 

RETURN 

END 

C 

END$ 


429 


STGGEX  1=00004  IS  ON  CROOOIS  USING  00004  BLKS  R=0000 


0001  FTN4 

0002  C 

0003  C 

0004  C 

0005 

0006  C 

0007 

0008  C 

0009 

0010 
0011 
0012 

0013  C 

0014  C 

0015  C 

0016 

0017  C 

0018  C 

0019  C 

0020 
0021 

0022  C 

0023  C 

0024  C 

0025 

0026  C 

0027  C 

0028  C 

0029 

0030 

0031  C 

0032 

0033 


tsge:  gciieduling  program  - claim  swap  control  tt 

PROGRAM  TSGEX 

COMMON  I COM  <6176) 

EQUIVALENCE  (ICOM  (51 )>  ISTRK)y 
(ICOM  (52)  y IGECDy 
(ICOM  (53)y  ICODDy 
(ICOM  (54)y  LEN) 

RECOVER  PARAMETERS 

CALL  RMPAR  (ICOM  (51)) 

READ  COMMON  FROM  THE  DISC 

CALL  EXEC  (ly66yIC0My6144yISTRKyISECT) 

CALL  EXEC  (ly66yIC0M(6145)yLENyISTRK-flyISECT) 


SCHEDULE  TSGE 


CALL  TSGE 

WRITE  COMMON  BACK  TO  THE  DISC 

CALL  EXEC  (2y66yIC0My6144yISTRKy ISECT) 

CALL  EXEC  (2y66yIC0M(6145)yLENylSTRKTlyISECT) 


END$ 


END 


STSIFS  T=0000^  IS  ON  CR00015  USING  00002  BLKS  R=0000 


0001 

0002 

0003 

0004 

0005 

0006 

0007 

0008 

0009 

0010 
0011 
0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 


n'N4 

C 

C FILE  t &TSIFS 

C tttt  rSlFG  SUBROUTINES  USING  CLAIM  SWAP  CONTROL  tttt 

C 

SUBROUTINE  TSXBA 
COMMON  ICOM  (6176) 

INTEGER  TSXBX  (3) 

DATA  TSXBX  / 2HTSy  2HXBy  2HX  / 

CALL  SWAPC  (TSXBX) 

RETURN 

END 

C 

SUBROUTINE  TSXFS 
COMMON  ICOM  (6176) 

INTEGER  TSXFX  (3) 

DATA  TSXFX  / 2HTSy  2HXF?  2HX  / 

CALL  SWAPC  (TSXFX) 

RETURN 

END 

END$ 
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?<TGIFO  1=00004  IS  ON  CR00015  USING  00004  BLKS  R=0000 


0001 

F fN4 

0002 

C 

0003 

G 

TSIFN  SCHLDULING  Pf^lGGRAM  -•  GLAIN  SWAP  CONTROL 

0004 

C 

0005 

PROGRAM  TSIFO 

0006 

C 

0007 

GOMMON  ICON  (6176) 

OOOS 

G 

0009 

EQUIOALLNCL  (ICON  (51) y ISTRK)? 

0010 

> (ICON  (52) y I SECT)? 

001 1 

> (ICCM  (53)y  lCODE)y 

0012 

> (ICOM  (54)y  LEN) 

0013 

C 

0014 

G 

RECOVER  PARAMETERS 

0015 

G 

0016 

GALL  RMPAR  (ICOM  (51)) 

0017 

G 

0018 

G 

READ  COMMON  FROM  THE  DISC 

0019 

C 

0020 

GALL  EXEC  ( 1 y 66 ? ICOM y 61 44 y 1ST RK ? ISECT ) 

0021 

GALL  EXEG  ( 1 y 66 y ICOM ( 6145 ) y LEN y ISTRK-M  y ISECT ) 

0022 

C 

0023 

G 

SCHEDULE  TSIFN 

0024 

G 

0025 

GALL  TSIFN 

0026 

C 

0027 

G 

URITE  COMMON  BACK  TO  THE  DISC 

0028 

C 

0029 

CALL  EXEC  (2y66y lC0My6144y ISTRKy ISECT) 

0030 

CALL  EXEC  (2y66yIC0M(6145)  yLENylSTRK-fly  ISECT) 

0031 

C 

0032 

END 

0033 

FND$ 
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&TSIFX  T=00004  IS  ON  CROOOllii  USING  00004  BLKS  R=0000 


0001 

0002 

0003 

0004 

0005 

0006 
0007 
OOOG 
0007 
0010 
0011 
0012 

0013 

0014 

0015 

0016 

0017 

0018 

0019 

0020 
0021 


FTN4 

C 

C tt  TSIFG  SCHEDULING  PROGRAM  - CLAIM  SWAP  CONTROL  tt 

C 

PROGRAM  TSIFX 
C 

COMMON  I COM  (6176) 

C 

EQUIVALENCE  (ICOM  <51 )»  ISTRK)» 

> (ICOM  (52) r I SECT)? 

> (ICOM  (53)?  I CODE)? 

> (ICOM  (54)?  LEN) 

C 

C RECOVER  PARAMETERS 

C 

CALL  RMPAR  (ICOM  (51)) 

C 

C READ  COMMON  FROM  THE  DISC 

C 

CALL  EXEC  (1?66?IC0M?6144?ISTRK?ISECT) 

CALL  EXEC  (1?66?IC0M(6145)?LEN?ISTRK-M?ISECT) 


0022  C 

0023  C 

0024  C 

0025 

0026  C 

0027  C 
0023  C 


SCHEDULE  TSIFG 
CALL  TSIFG 

WRITE  COMMON  BACK  TO  THE  DISC 


0029 

0030 

0031  C 


CALL  EXEC  (2?66? IC0M?6144? ISTRK? ISECT) 

CALL  EXEC  (2?66?IC0M(6145)?LEN?ISTRK-M?ISECT) 


0032  END 

0033  ENDT- 
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STSIHX  l==0000-1  IS  ON  CROOOIS  LfGING  00004  BLKG  R=0000 


0001 

rTN4 

0002 

8 

0003 

C 

tt  TSIMB  SCHEDULING  PROGRAN  ~ CLAIM  SWAP  CONTROL 

0004 

C 

0000 

PROGRAM  TGIHX 

0006 

C 

0007 

COMMON  ICON  (6176) 

0008 

C 

0009 

EOUIOALLNCE  (ICOM 

(51 )y  ISTRK)y 

0010 

(I  COM 

(52>y  ISECT)y 

0011 

=•  (ICON 

(53)y  ICODE)y 

0012 

(ICOM 

(54)y  LEN) 

C013 

C 

0014 

C 

RECOVER  PARAMETERS 

0015 

C 

0016 

CALL  RMPAR  (ICOM  ( 

51 ) ) 

0017 

C 

0018 

C 

READ  COMMON  FROM  THE  DISC 

0019 

C 

0020 

r 

CALL  EXEC  (ly66y IC0My6144yISTRK? ISECT) 

0021 

CALL  EXEC  ( 1 y66? IC0M(6145) yLENy ISTRKTl y ISECT) 

0022 

C 

0023 

c 

SCHEDULE  TS I HD 

0024 

c 

0025 

CALL  TSIHD 

0026 

c 

0027 

c 

WRITE  COMMON  BACK 

TO  THE  DISC 

0028 

c 

0029 

CALL  EXEC  (2?66y IC0My6144y ISTRKy ISECT) 

0030 

CALL  EXEC  (2y66y IC0M(6145) yLENylSTRKTly ISECT) 

0031 

c 

0032 

END 

0033 

ENIi$ 
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gTGSCO 


T=:00004  IG  ON  CN00015  UGING  00004  ULKG  R==0000 


0001 

0002 

0003 

0004 
OOOG 
0006 
0007 
OOOG 

0009 

0010 
0011 
0012 

0013 

0014 
OOIG 
0016 

0017 

0018 

0019 

0020 
0021 
0022 

0023 

0024 

0025 

0026 

0027 

0028 

0029 

0030 

0031 

0032 

0033 


C 

C 

C 


C 


r* 


c 

c 

c 

c 

c 

c 


c 

c 

c 

c 

c 


c 


c 


END$ 


/p  /|> 


TGGCF 


on 

\Lj  I 


lEDULING  PROGRAM 


CLAIM  SWAP 


CONTROL 


PROGRAM  TGGCO 

COMMON  I COM  (6176) 

LGUIVALLNCL  (ICON  (51)  ISTRK)y 
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